Branch data Line data Source code
1 : : /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 : : Copyright (C) 2005-2025 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 : 5946 : gfc_omp_is_allocatable_or_ptr (const_tree decl)
66 : : {
67 : 5946 : return (DECL_P (decl)
68 : 5946 : && (GFC_DECL_GET_SCALAR_POINTER (decl)
69 : 4215 : || 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 : 46220 : gfc_omp_is_optional_argument (const_tree decl)
81 : : {
82 : : /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
83 : 30416 : return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl))
84 : 46220 : && DECL_LANG_SPECIFIC (decl)
85 : 20885 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
86 : 20701 : && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
87 : 20466 : && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
88 : 66661 : && 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 : 22153 : gfc_omp_check_optional_argument (tree decl, bool for_present_check)
101 : : {
102 : 22153 : if (!for_present_check)
103 : 2175 : return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE;
104 : :
105 : 19978 : if (!DECL_LANG_SPECIFIC (decl))
106 : : return NULL_TREE;
107 : :
108 : 5444 : tree orig_decl = decl;
109 : :
110 : : /* For assumed-shape arrays, a local decl with arg->data is used. */
111 : 5444 : if (TREE_CODE (decl) != PARM_DECL
112 : 5444 : && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
113 : 2040 : || 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 : 5444 : if (decl == NULL_TREE
118 : 5307 : || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
119 : 5307 : || !DECL_LANG_SPECIFIC (decl)
120 : 10347 : || !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 : 18728 : gfc_omp_array_data (tree decl, bool type_only)
159 : : {
160 : 18728 : tree type = TREE_TYPE (decl);
161 : :
162 : 18728 : if (POINTER_TYPE_P (type))
163 : 10187 : type = TREE_TYPE (type);
164 : :
165 : 18728 : if (!GFC_DESCRIPTOR_TYPE_P (type))
166 : : return NULL_TREE;
167 : :
168 : 4548 : if (type_only)
169 : 3328 : return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
170 : :
171 : 1220 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
172 : 414 : decl = build_fold_indirect_ref (decl);
173 : :
174 : 1220 : decl = gfc_conv_descriptor_data_get (decl);
175 : 1220 : STRIP_NOPS (decl);
176 : 1220 : return decl;
177 : : }
178 : :
179 : : /* Return the byte-size of the passed array descriptor. */
180 : :
181 : : tree
182 : 18 : gfc_omp_array_size (tree decl, gimple_seq *pre_p)
183 : : {
184 : 18 : stmtblock_t block;
185 : 18 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
186 : 18 : decl = build_fold_indirect_ref (decl);
187 : 18 : tree type = TREE_TYPE (decl);
188 : 18 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
189 : 18 : bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
190 : 2 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
191 : 18 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
192 : 18 : gfc_init_block (&block);
193 : 54 : tree size = gfc_full_array_size (&block, decl,
194 : 18 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
195 : 18 : size = fold_convert (size_type_node, size);
196 : 18 : tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
197 : 18 : if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
198 : 6 : elemsz = gfc_conv_descriptor_elem_len (decl);
199 : : else
200 : 12 : elemsz = TYPE_SIZE_UNIT (elemsz);
201 : 18 : size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
202 : 18 : if (!allocatable)
203 : 0 : gimplify_and_add (gfc_finish_block (&block), pre_p);
204 : : else
205 : : {
206 : 18 : tree var = create_tmp_var (size_type_node);
207 : 18 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
208 : 18 : tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
209 : : gfc_conv_descriptor_data_get (decl),
210 : : null_pointer_node);
211 : 18 : 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 : 18 : gimplify_and_add (tmp, pre_p);
215 : 18 : size = var;
216 : : }
217 : 18 : 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 : 457535 : gfc_omp_privatize_by_reference (const_tree decl)
226 : : {
227 : 457535 : tree type = TREE_TYPE (decl);
228 : :
229 : 457535 : if (TREE_CODE (type) == REFERENCE_TYPE
230 : 457535 : && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
231 : : return true;
232 : :
233 : 434219 : if (TREE_CODE (type) == POINTER_TYPE
234 : 434219 : && gfc_omp_is_optional_argument (decl))
235 : : return true;
236 : :
237 : 425133 : if (TREE_CODE (type) == POINTER_TYPE)
238 : : {
239 : 32780 : 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 : 32780 : if (GFC_DECL_GET_SCALAR_POINTER (decl)
247 : 31253 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
248 : 28861 : || GFC_DECL_CRAY_POINTEE (decl)
249 : 28855 : || GFC_DECL_ASSOCIATE_VAR_P (decl)
250 : 38287 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
251 : : return false;
252 : :
253 : 20834 : if (!DECL_ARTIFICIAL (decl)
254 : 20834 : && 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 : 13444 : if (DECL_LANG_SPECIFIC (decl)
260 : 13444 : && 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 : 8451 : 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 : 8451 : 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 : 8406 : if (DECL_ARTIFICIAL (decl)
287 : 1586 : && ! GFC_DECL_RESULT (decl)
288 : 9968 : && ! (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 : 7170 : if (GFC_DECL_CRAY_POINTEE (decl))
297 : : return OMP_CLAUSE_DEFAULT_PRIVATE;
298 : :
299 : : /* Assumed-size arrays are predetermined shared. */
300 : 7134 : 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 : 7850 : && 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 : 7066 : if (TREE_CODE (decl) == PARM_DECL
313 : 1895 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
314 : 7851 : && 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 : 7050 : if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
322 : : return OMP_CLAUSE_DEFAULT_SHARED;
323 : :
324 : 7021 : 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 : 5118 : if (VAR_P (decl) && TREE_READONLY (decl)
333 : 7000 : && (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 : 3912 : gfc_omp_predetermined_mapping (tree decl)
345 : : {
346 : 3912 : if (DECL_ARTIFICIAL (decl)
347 : 879 : && ! GFC_DECL_RESULT (decl)
348 : 4785 : && ! (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 : 3082 : if (TREE_CODE (decl) == PARM_DECL
357 : 1815 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
358 : 3461 : && 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 : 1267 : if (VAR_P (decl) && TREE_READONLY (decl)
363 : 3075 : && (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 : 128 : gfc_omp_report_decl (tree decl)
375 : : {
376 : 128 : if (DECL_ARTIFICIAL (decl)
377 : 3 : && DECL_LANG_SPECIFIC (decl)
378 : 131 : && 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 : 121392 : gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok,
391 : : bool shallow_alloc_only=false)
392 : : {
393 : 121392 : tree field, ftype;
394 : :
395 : 121392 : if (POINTER_TYPE_P (type))
396 : : {
397 : 3458 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
398 : 3458 : || (ptr_ok && GFC_DECL_GET_SCALAR_POINTER (decl)))
399 : 2380 : type = TREE_TYPE (type);
400 : 1078 : else if (GFC_DECL_GET_SCALAR_POINTER (decl))
401 : : return false;
402 : : }
403 : :
404 : 121209 : if (!ptr_ok
405 : 98663 : && GFC_DESCRIPTOR_TYPE_P (type)
406 : 124355 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
407 : 2886 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
408 : : return false;
409 : :
410 : 120946 : if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
411 : 12307 : type = gfc_get_element_type (type);
412 : :
413 : 120946 : if (TREE_CODE (type) != RECORD_TYPE)
414 : : return false;
415 : :
416 : 9958 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
417 : : {
418 : 8954 : ftype = TREE_TYPE (field);
419 : 8954 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
420 : : return true;
421 : 8120 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
422 : 8120 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
423 : : return true;
424 : 5969 : if (!shallow_alloc_only
425 : 5969 : && 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 : 65381 : gfc_is_polymorphic_nonptr (tree type)
473 : : {
474 : 65381 : if (POINTER_TYPE_P (type))
475 : 3650 : type = TREE_TYPE (type);
476 : 65381 : 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 : 107 : gfc_is_unlimited_polymorphic_nonptr (tree type)
484 : : {
485 : 107 : if (POINTER_TYPE_P (type))
486 : 0 : type = TREE_TYPE (type);
487 : 107 : if (!GFC_CLASS_TYPE_P (type))
488 : : return false;
489 : :
490 : 107 : tree field = TYPE_FIELDS (type); /* _data */
491 : 107 : gcc_assert (field);
492 : 107 : field = DECL_CHAIN (field); /* _vptr */
493 : 107 : gcc_assert (field);
494 : 107 : field = DECL_CHAIN (field);
495 : 107 : 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 : 3912 : gfc_omp_allocatable_p (tree decl)
505 : : {
506 : 3912 : if (!DECL_P (decl))
507 : : return false;
508 : :
509 : 3912 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
510 : : return true;
511 : :
512 : 3678 : tree type = TREE_TYPE (decl);
513 : 3678 : if (gfc_omp_privatize_by_reference (decl))
514 : 1802 : type = TREE_TYPE (type);
515 : :
516 : 3678 : if (GFC_DESCRIPTOR_TYPE_P (type)
517 : 3678 : && 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 : 14454 : gfc_omp_private_outer_ref (tree decl)
528 : : {
529 : 14454 : tree type = TREE_TYPE (decl);
530 : :
531 : 14454 : if (gfc_omp_privatize_by_reference (decl))
532 : 617 : type = TREE_TYPE (type);
533 : :
534 : 14454 : if (GFC_DESCRIPTOR_TYPE_P (type)
535 : 14454 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
536 : : return true;
537 : :
538 : 14328 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
539 : : return true;
540 : :
541 : 14242 : 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 : 9214 : gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
905 : : {
906 : 9214 : tree type = TREE_TYPE (dest), ptr, size, call;
907 : 9214 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
908 : 9214 : tree cond, then_b, else_b;
909 : 9214 : stmtblock_t block, cond_block;
910 : :
911 : 9214 : 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 : 9214 : if (DECL_P (OMP_CLAUSE_DECL (clause))
916 : 9214 : && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
917 : 27 : return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
918 : :
919 : 9187 : if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
920 : 6152 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
921 : 9368 : && 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 : 9187 : 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 : 9147 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
995 : 138 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
996 : 9171 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
997 : 77 : || !POINTER_TYPE_P (type)))
998 : : {
999 : 8958 : 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 : 8938 : 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 : 189 : gfc_start_block (&block);
1015 : :
1016 : 189 : gfc_init_block (&cond_block);
1017 : :
1018 : 189 : gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src));
1019 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
1020 : : {
1021 : 114 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
1022 : 114 : size = gfc_conv_descriptor_ubound_get (dest, rank);
1023 : 114 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1024 : : size,
1025 : : gfc_conv_descriptor_lbound_get (dest, rank));
1026 : 114 : size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1027 : : size, gfc_index_one_node);
1028 : 114 : 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 : 114 : tree esize = fold_convert (gfc_array_index_type,
1033 : : TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1034 : 114 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1035 : : size, esize);
1036 : 114 : size = unshare_expr (size);
1037 : 114 : 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 : 189 : ptr = gfc_create_var (pvoid_type_node, NULL);
1043 : 189 : gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
1044 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
1045 : 114 : 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 : 189 : tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
1051 : 189 : ? gfc_conv_descriptor_data_get (src) : src;
1052 : 189 : srcptr = unshare_expr (srcptr);
1053 : 189 : srcptr = fold_convert (pvoid_type_node, srcptr);
1054 : 189 : call = build_call_expr_loc (input_location,
1055 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
1056 : : srcptr, size);
1057 : 189 : gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
1058 : 189 : 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 : 189 : then_b = gfc_finish_block (&cond_block);
1066 : :
1067 : 189 : gfc_init_block (&cond_block);
1068 : 189 : if (GFC_DESCRIPTOR_TYPE_P (type))
1069 : 114 : 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 : 189 : else_b = gfc_finish_block (&cond_block);
1075 : :
1076 : 189 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1077 : : unshare_expr (srcptr), null_pointer_node);
1078 : 189 : 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 : 189 : if (DECL_P (dest))
1083 : 121 : suppress_warning (dest, OPT_Wuninitialized);
1084 : :
1085 : 189 : 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 : 28665 : gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
1587 : : {
1588 : 28665 : if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1589 : : return;
1590 : :
1591 : 6948 : tree decl = OMP_CLAUSE_DECL (c);
1592 : 6948 : 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 : 6948 : 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 : 7319 : && 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 : 6947 : tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1609 : 6947 : tree present = gfc_omp_check_optional_argument (decl, true);
1610 : 6947 : tree orig_decl = NULL_TREE;
1611 : 6947 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
1612 : : {
1613 : 1299 : if (!gfc_omp_privatize_by_reference (decl)
1614 : 167 : && !GFC_DECL_GET_SCALAR_POINTER (decl)
1615 : 103 : && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
1616 : 3 : && !GFC_DECL_CRAY_POINTEE (decl)
1617 : 1302 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
1618 : : return;
1619 : 1296 : orig_decl = decl;
1620 : :
1621 : 1296 : c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
1622 : 1296 : OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
1623 : 1296 : OMP_CLAUSE_DECL (c4) = decl;
1624 : 1296 : OMP_CLAUSE_SIZE (c4) = size_int (0);
1625 : 1296 : decl = build_fold_indirect_ref (decl);
1626 : 1296 : if (present
1627 : 1296 : && (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 : 1229 : OMP_CLAUSE_DECL (c) = decl;
1648 : 1229 : OMP_CLAUSE_SIZE (c) = NULL_TREE;
1649 : : }
1650 : 1296 : if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
1651 : 1296 : && (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 : 6944 : 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 : 5215 : if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
1804 : 1207 : OMP_CLAUSE_SIZE (c)
1805 : 3409 : = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
1806 : 995 : : TYPE_SIZE_UNIT (TREE_TYPE (decl));
1807 : :
1808 : 5215 : tree type = TREE_TYPE (decl);
1809 : 5215 : if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type)))
1810 : 0 : type = TREE_TYPE (type);
1811 : 5215 : if (!openacc
1812 : 5215 : && orig_decl != NULL_TREE
1813 : 5215 : && 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 : 28 : tree size = create_tmp_var (TREE_TYPE (OMP_CLAUSE_SIZE (c)));
1818 : 28 : gfc_allocate_lang_decl (size);
1819 : 28 : GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
1820 : 28 : gimplify_assign (size, OMP_CLAUSE_SIZE (c), pre_p);
1821 : 28 : OMP_CLAUSE_SIZE (c) = size;
1822 : : }
1823 : : }
1824 : 6944 : tree last = c;
1825 : 6944 : 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 : 6944 : 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 : 6944 : 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 : 6944 : if (c4)
1841 : : {
1842 : 1296 : OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last);
1843 : 1296 : 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 : 545 : 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 : 545 : tree one = build_int_cst (size_type_node, 1);
1858 : :
1859 : 545 : STRIP_NOPS (data);
1860 : 545 : if (!POINTER_TYPE_P (TREE_TYPE (data)))
1861 : : {
1862 : 275 : gcc_assert (TREE_CODE (data) == INDIRECT_REF);
1863 : 275 : data = TREE_OPERAND (data, 0);
1864 : : }
1865 : :
1866 : : /* data_array[offset_data] = data; */
1867 : 545 : tree tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
1868 : : unshare_expr (data_array), offset_data,
1869 : : NULL_TREE, NULL_TREE);
1870 : 545 : gimplify_assign (tmp, data, seq);
1871 : :
1872 : : /* offset_data++ */
1873 : 545 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
1874 : 545 : gimplify_assign (offset_data, tmp, seq);
1875 : :
1876 : : /* data_array[offset_data] = &data; */
1877 : 545 : tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
1878 : : unshare_expr (data_array),
1879 : : offset_data, NULL_TREE, NULL_TREE);
1880 : 545 : gimplify_assign (tmp, build_fold_addr_expr (data), seq);
1881 : :
1882 : : /* offset_data++ */
1883 : 545 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
1884 : 545 : gimplify_assign (offset_data, tmp, seq);
1885 : :
1886 : : /* sizes_array[offset] = size */
1887 : 545 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1888 : 545 : TYPE_SIZE_UNIT (size_type_node), offset);
1889 : 545 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
1890 : : sizes_array, tmp);
1891 : 545 : gimple_seq seq2 = NULL;
1892 : 545 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1893 : 545 : gimple_seq_add_seq (seq, seq2);
1894 : 545 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1895 : 545 : gimplify_assign (tmp, size, seq);
1896 : :
1897 : : /* FIXME: tkind |= talign << talign_shift; */
1898 : : /* kinds_array[offset] = tkind. */
1899 : 545 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1900 : 545 : TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
1901 : 545 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
1902 : : kinds_array, tmp);
1903 : 545 : seq2 = NULL;
1904 : 545 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1905 : 545 : gimple_seq_add_seq (seq, seq2);
1906 : 545 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1907 : 545 : gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
1908 : :
1909 : : /* offset++ */
1910 : 545 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
1911 : 545 : gimplify_assign (offset, tmp, seq);
1912 : :
1913 : : /* sizes_array[offset] = bias (= 0). */
1914 : 545 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1915 : 545 : TYPE_SIZE_UNIT (size_type_node), offset);
1916 : 545 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
1917 : : sizes_array, tmp);
1918 : 545 : seq2 = NULL;
1919 : 545 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1920 : 545 : gimple_seq_add_seq (seq, seq2);
1921 : 545 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1922 : 545 : gimplify_assign (tmp, build_zero_cst (size_type_node), seq);
1923 : :
1924 : 545 : gcc_assert (gimple_code (ctx) == GIMPLE_OMP_TARGET);
1925 : 545 : tkind = (gimple_omp_target_kind (ctx) == GF_OMP_TARGET_KIND_EXIT_DATA
1926 : 545 : ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH);
1927 : :
1928 : : /* kinds_array[offset] = tkind. */
1929 : 545 : tmp = build2_loc (loc, MULT_EXPR, size_type_node,
1930 : 545 : TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
1931 : 545 : tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
1932 : : kinds_array, tmp);
1933 : 545 : seq2 = NULL;
1934 : 545 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
1935 : 545 : gimple_seq_add_seq (seq, seq2);
1936 : 545 : tmp = build_fold_indirect_ref_loc (loc, tmp);
1937 : 545 : gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
1938 : :
1939 : : /* offset++ */
1940 : 545 : tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
1941 : 545 : gimplify_assign (offset, tmp, seq);
1942 : 545 : }
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 : 1098 : 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 : 1098 : tree type = TREE_TYPE (decl);
1959 : 1098 : if (TREE_CODE (type) != RECORD_TYPE)
1960 : : return;
1961 : 2790 : for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
1962 : : {
1963 : 1696 : type = TREE_TYPE (field);
1964 : 1696 : if (gfc_is_polymorphic_nonptr (type)
1965 : 1294 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
1966 : 2692 : || (GFC_DESCRIPTOR_TYPE_P (type)
1967 : 330 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE))
1968 : : {
1969 : 1030 : tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
1970 : : decl, field, NULL_TREE);
1971 : 1030 : 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 : 666 : else if (GFC_DECL_GET_SCALAR_POINTER (field)
1977 : 666 : || GFC_DESCRIPTOR_TYPE_P (type))
1978 : 0 : continue;
1979 : 666 : else if (gfc_has_alloc_comps (TREE_TYPE (field), field, false))
1980 : : {
1981 : 160 : tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
1982 : : decl, field, NULL_TREE);
1983 : 160 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1984 : 80 : 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 : 80 : 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 : 832 : 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 : 832 : tree tmp;
2003 : :
2004 : : /* var = begin. */
2005 : 832 : gimplify_assign (var, begin, seq1);
2006 : :
2007 : : /* Loop: for (var = begin; var <cond> end; var += step). */
2008 : 832 : tree label_loop = create_artificial_label (loc);
2009 : 832 : tree label_cond = create_artificial_label (loc);
2010 : :
2011 : 832 : gimplify_and_add (fold_build1_loc (loc, GOTO_EXPR, void_type_node,
2012 : : label_cond), seq1);
2013 : 832 : 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 : 832 : tmp = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (var), var, step);
2019 : 832 : gimplify_assign (var, tmp, seq2);
2020 : 832 : gimple_seq_add_stmt (seq2, gimple_build_label (label_cond));
2021 : 832 : tmp = fold_build2_loc (loc, cond, boolean_type_node, var, end);
2022 : 832 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
2023 : : build_empty_stmt (loc));
2024 : 832 : gimplify_and_add (tmp, seq2);
2025 : 832 : }
2026 : :
2027 : : /* Return size variable with the size of an array. */
2028 : : static tree
2029 : 440 : gfc_omp_get_array_size (location_t loc, tree desc, gimple_seq *seq)
2030 : : {
2031 : 440 : tree tmp;
2032 : 440 : gimple_seq seq1 = NULL, seq2 = NULL;
2033 : 440 : tree size = build_decl (loc, VAR_DECL, create_tmp_var_name ("size"),
2034 : : size_type_node);
2035 : 440 : tree extent = build_decl (loc, VAR_DECL, create_tmp_var_name ("extent"),
2036 : : gfc_array_index_type);
2037 : 440 : tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
2038 : : signed_char_type_node);
2039 : :
2040 : 440 : tree begin = build_zero_cst (signed_char_type_node);
2041 : 440 : tree end;
2042 : 440 : if (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE_CONT
2043 : 440 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE)
2044 : 8 : end = gfc_conv_descriptor_rank (desc);
2045 : : else
2046 : 432 : end = build_int_cst (signed_char_type_node,
2047 : 432 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
2048 : 440 : 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 : 440 : gimplify_assign (size, build_int_cst (size_type_node, 1), seq);
2056 : :
2057 : 440 : gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, &seq1, &seq2);
2058 : 440 : gimple_seq_add_seq (seq, seq1);
2059 : :
2060 : 440 : 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 : 440 : tmp = fold_build2_loc (loc, PLUS_EXPR, gfc_array_index_type,
2064 : : tmp, gfc_index_one_node);
2065 : 440 : gimplify_assign (extent, tmp, seq);
2066 : 440 : tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node,
2067 : : extent, gfc_index_zero_node);
2068 : 440 : 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 : 440 : gimplify_and_add (tmp, seq);
2074 : : /* size *= extent. */
2075 : 440 : gimplify_assign (size, fold_build2_loc (loc, MULT_EXPR, size_type_node, size,
2076 : : fold_convert (size_type_node,
2077 : : extent)), seq);
2078 : 440 : gimple_seq_add_seq (seq, seq2);
2079 : 440 : 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 : 392 : gfc_omp_elmental_loop (location_t loc, tree decl, tree size, tree elem_len,
2087 : : gimple_seq *seq1, gimple_seq *seq2)
2088 : : {
2089 : 392 : tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
2090 : : size_type_node);
2091 : 392 : tree begin = build_zero_cst (size_type_node);
2092 : 392 : tree end = size;
2093 : 392 : tree step = build_int_cst (size_type_node, 1);
2094 : 392 : tree ptr;
2095 : :
2096 : 392 : gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, seq1, seq2);
2097 : :
2098 : 392 : tree type = TREE_TYPE (decl);
2099 : 392 : if (POINTER_TYPE_P (type))
2100 : : {
2101 : 308 : type = TREE_TYPE (type);
2102 : 308 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
2103 : 308 : decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
2104 : : }
2105 : : else
2106 : : {
2107 : 84 : gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
2108 : 84 : decl = build_fold_addr_expr_loc (loc, decl);
2109 : : }
2110 : 392 : decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
2111 : 392 : tree tmp = build2_loc (loc, MULT_EXPR, size_type_node, idx,
2112 : : fold_convert (size_type_node, elem_len));
2113 : 392 : ptr = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, tmp);
2114 : 392 : gimple_seq seq3 = NULL;
2115 : 392 : ptr = force_gimple_operand (ptr, &seq3, true, NULL_TREE);
2116 : 392 : gimple_seq_add_seq (seq1, seq3);
2117 : :
2118 : 392 : 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 : 1500 : 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 : 1500 : tree tmp;
2138 : 1500 : tree type = TREE_TYPE (decl);
2139 : 1500 : if (POINTER_TYPE_P (type))
2140 : 496 : type = TREE_TYPE (type);
2141 : 1500 : tree end_label = NULL_TREE;
2142 : 1500 : tree size = NULL_TREE, elem_len = NULL_TREE;
2143 : :
2144 : 1500 : bool poly = gfc_is_polymorphic_nonptr (type);
2145 : 1500 : if (poly && is_cnt && !*poly_warned)
2146 : : {
2147 : 71 : 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 : 69 : warning_at (loc, OPT_Wopenmp,
2154 : : "Mapping of polymorphic list item %qD is "
2155 : : "unspecified behavior", decl);
2156 : 71 : *poly_warned = true;
2157 : : }
2158 : 1500 : if (do_alloc_check)
2159 : : {
2160 : 1288 : tree then_label = create_artificial_label (loc);
2161 : 1288 : end_label = create_artificial_label (loc);
2162 : 1288 : tmp = decl;
2163 : 1288 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE
2164 : 1288 : || (POINTER_TYPE_P (TREE_TYPE (tmp))
2165 : 476 : && (POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
2166 : 476 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))))))
2167 : 8 : tmp = build_fold_indirect_ref_loc (loc, tmp);
2168 : 1288 : if (poly)
2169 : 462 : tmp = gfc_class_data_get (tmp);
2170 : 1288 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2171 : 564 : tmp = gfc_conv_descriptor_data_get (tmp);
2172 : 1288 : gimple_seq seq2 = NULL;
2173 : 1288 : tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
2174 : 1288 : gimple_seq_add_seq (seq, seq2);
2175 : :
2176 : 1288 : gimple_seq_add_stmt (seq,
2177 : 1288 : gimple_build_cond (NE_EXPR, tmp, null_pointer_node,
2178 : : then_label, end_label));
2179 : 1288 : gimple_seq_add_stmt (seq, gimple_build_label (then_label));
2180 : : }
2181 : 1500 : tree class_decl = decl;
2182 : 1500 : if (poly)
2183 : : {
2184 : 462 : decl = gfc_class_data_get (decl);
2185 : 462 : type = TREE_TYPE (decl);
2186 : : }
2187 : 1500 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
2188 : : {
2189 : 748 : decl = build_fold_indirect_ref (decl);
2190 : 748 : type = TREE_TYPE (decl);
2191 : : }
2192 : :
2193 : 1500 : if (is_cnt && do_copy)
2194 : : {
2195 : 545 : tree tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node,
2196 : : num, build_int_cst (size_type_node, 1));
2197 : 545 : gimplify_assign (num, tmp, seq);
2198 : : }
2199 : 955 : else if (do_copy)
2200 : : {
2201 : : /* copy data pointer */
2202 : 545 : tree bytesize;
2203 : 545 : 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 : 270 : elem_len = (poly ? gfc_class_vtab_size_get (class_decl)
2208 : 165 : : gfc_conv_descriptor_elem_len (decl));
2209 : 540 : tmp = (POINTER_TYPE_P (TREE_TYPE (decl))
2210 : 270 : ? build_fold_indirect_ref (decl) : decl);
2211 : 270 : size = gfc_omp_get_array_size (loc, tmp, seq);
2212 : 270 : 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 : 270 : tmp = gfc_conv_descriptor_data_get (decl);
2216 : : }
2217 : 275 : else if (poly)
2218 : : {
2219 : 126 : tmp = decl;
2220 : 126 : bytesize = fold_convert (size_type_node,
2221 : : gfc_class_vtab_size_get (class_decl));
2222 : : }
2223 : : else
2224 : : {
2225 : 149 : tmp = decl;
2226 : 149 : bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl));
2227 : : }
2228 : 545 : unsigned HOST_WIDE_INT tkind2 = tkind;
2229 : 545 : if (!is_cnt
2230 : 545 : && (tkind == GOMP_MAP_ALLOC
2231 : 517 : || (tkind == GOMP_MAP_FROM
2232 : 88 : && (gimple_omp_target_kind (ctx)
2233 : : != GF_OMP_TARGET_KIND_EXIT_DATA)))
2234 : 589 : && 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 : 545 : 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 : 1500 : tmp = decl;
2243 : 1500 : 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 : 1500 : if (poly || gfc_has_alloc_comps (type, tmp, true))
2247 : : {
2248 : 1018 : gimple_seq seq2 = NULL;
2249 : 1018 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
2250 : : {
2251 : 308 : if (elem_len == NULL_TREE)
2252 : : {
2253 : 170 : elem_len = gfc_conv_descriptor_elem_len (decl);
2254 : 170 : size = fold_convert (size_type_node,
2255 : : gfc_omp_get_array_size (loc, decl, seq));
2256 : : }
2257 : 308 : decl = gfc_conv_descriptor_data_get (decl);
2258 : 308 : decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
2259 : 308 : decl = build_fold_indirect_ref_loc (loc, decl);
2260 : : }
2261 : 710 : else if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2262 : : {
2263 : 84 : 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 : 84 : elem_len = TYPE_SIZE_UNIT (TREE_TYPE (type));
2268 : 84 : size = fold_convert (size_type_node, GFC_TYPE_ARRAY_SIZE (type));
2269 : 84 : decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
2270 : 84 : decl = build_fold_indirect_ref_loc (loc, decl);
2271 : : }
2272 : 626 : else if (POINTER_TYPE_P (TREE_TYPE (decl)))
2273 : 0 : decl = build_fold_indirect_ref (decl);
2274 : :
2275 : 1018 : 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 : 1018 : gimple_seq_add_seq (seq, seq2);
2280 : : }
2281 : 1500 : if (end_label)
2282 : 1288 : gimple_seq_add_stmt (seq, gimple_build_label (end_label));
2283 : 1500 : }
2284 : :
2285 : :
2286 : : /* Which map types to check/handle for deep mapping. */
2287 : : static bool
2288 : 37532 : gfc_omp_deep_map_kind_p (tree clause)
2289 : : {
2290 : 37532 : switch (OMP_CLAUSE_CODE (clause))
2291 : : {
2292 : 33976 : case OMP_CLAUSE_MAP:
2293 : 33976 : 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 : 33976 : 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 : 89067 : gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause)
2362 : : {
2363 : 89067 : if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause))
2364 : : return NULL_TREE;
2365 : 20563 : tree decl = OMP_CLAUSE_DECL (clause);
2366 : 20563 : if (OMP_CLAUSE_SIZE (clause) != NULL_TREE
2367 : 20553 : && DECL_P (OMP_CLAUSE_SIZE (clause))
2368 : 6647 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause))
2369 : 20952 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)))
2370 : : /* Saved decl. */
2371 : 389 : decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause));
2372 : 20174 : else if (TREE_CODE (decl) == MEM_REF || TREE_CODE (decl) == INDIRECT_REF)
2373 : : /* The following can happen for, e.g., class(t) :: var(..) */
2374 : 11614 : decl = TREE_OPERAND (decl, 0);
2375 : 20563 : 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 : 20563 : if (DECL_P (decl)
2379 : 12613 : && DECL_LANG_SPECIFIC (decl)
2380 : 22811 : && 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 : 20563 : tree tmp = OMP_CLAUSE_CHAIN (clause);
2385 : 20563 : if (tmp != NULL_TREE
2386 : 15271 : && OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_CODE (clause)
2387 : 13741 : && OMP_CLAUSE_SIZE (tmp) != NULL_TREE
2388 : 13741 : && DECL_P (OMP_CLAUSE_SIZE (tmp))
2389 : 1390 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (tmp))
2390 : 20635 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl)
2391 : : return NULL_TREE;
2392 : 20563 : if (DECL_P (decl)
2393 : 12613 : && DECL_LANG_SPECIFIC (decl)
2394 : 22778 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
2395 : 29 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2396 : 20563 : tree type = TREE_TYPE (decl);
2397 : 20563 : if (POINTER_TYPE_P (type))
2398 : 12634 : type = TREE_TYPE (type);
2399 : 20563 : if (POINTER_TYPE_P (type))
2400 : 140 : type = TREE_TYPE (type);
2401 : 20563 : tmp = decl;
2402 : 22220 : while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
2403 : 2212 : tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2404 : 20563 : if (!gfc_is_polymorphic_nonptr (type)
2405 : 20563 : && !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 : 43048 : gfc_omp_deep_mapping_p (const gimple *ctx, tree clause)
2414 : : {
2415 : 43048 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2416 : 43048 : if (decl == NULL_TREE)
2417 : 42912 : return false;
2418 : : return true;
2419 : : }
2420 : :
2421 : : /* Handle gfc_omp_deep_mapping{,_cnt} */
2422 : : static tree
2423 : 45995 : 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 : 45995 : tree num = NULL_TREE;
2429 : 45995 : location_t loc = OMP_CLAUSE_LOCATION (clause);
2430 : 45995 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2431 : 45995 : bool poly_warned = false;
2432 : 45995 : 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 : 402 : if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
2437 : 402 : && (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC
2438 : 358 : || 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 : 390 : tree type = TREE_TYPE (decl);
2451 : 390 : if (POINTER_TYPE_P (type))
2452 : 198 : type = TREE_TYPE (type);
2453 : 390 : if (POINTER_TYPE_P (type))
2454 : 8 : type = TREE_TYPE (type);
2455 : 390 : bool poly = gfc_is_polymorphic_nonptr (type);
2456 : :
2457 : 390 : if (is_cnt)
2458 : : {
2459 : 195 : num = build_decl (loc, VAR_DECL,
2460 : : create_tmp_var_name ("n_deepmap"), size_type_node);
2461 : 195 : tree tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num,
2462 : : build_int_cst (size_type_node, 0));
2463 : 195 : gimple_add_tmp_var (num);
2464 : 195 : gimplify_and_add (tmp, seq);
2465 : : }
2466 : : else
2467 : 195 : gcc_assert (short_unsigned_type_node == TREE_TYPE (TREE_TYPE (kinds)));
2468 : :
2469 : 390 : bool do_copy = poly;
2470 : 390 : bool do_alloc_check = false;
2471 : 390 : tree token = NULL_TREE;
2472 : 390 : tree tmp = decl;
2473 : 390 : if (poly)
2474 : : {
2475 : 60 : tmp = TYPE_FIELDS (type);
2476 : 60 : type = TREE_TYPE (tmp);
2477 : : }
2478 : : else
2479 : 370 : while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
2480 : 48 : tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
2481 : 390 : if (TREE_CODE (tmp) == MEM_REF)
2482 : 4 : tmp = TREE_OPERAND (tmp, 0);
2483 : 390 : if (TREE_CODE (tmp) == SSA_NAME)
2484 : : {
2485 : 4 : gimple *def_stmt = SSA_NAME_DEF_STMT (tmp);
2486 : 4 : if (gimple_code (def_stmt) == GIMPLE_ASSIGN)
2487 : : {
2488 : 4 : tmp = gimple_assign_rhs1 (def_stmt);
2489 : 4 : if (poly)
2490 : : {
2491 : 0 : tmp = TYPE_FIELDS (type);
2492 : 0 : type = TREE_TYPE (tmp);
2493 : : }
2494 : : else
2495 : 8 : while (TREE_CODE (tmp) == COMPONENT_REF
2496 : 8 : || TREE_CODE (tmp) == ARRAY_REF)
2497 : 4 : 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 : 390 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
2503 : 182 : || GFC_DECL_GET_SCALAR_POINTER (tmp)
2504 : 404 : || (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 : 390 : if (!is_cnt
2511 : 195 : && OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
2512 : 191 : && (tkind == GOMP_MAP_ALLOC
2513 : 179 : || (tkind == GOMP_MAP_FROM
2514 : 29 : && (gimple_omp_target_kind (ctx)
2515 : : != GF_OMP_TARGET_KIND_EXIT_DATA)))
2516 : 426 : && (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 : 390 : tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true)
2523 : : : NULL_TREE);
2524 : 598 : if (POINTER_TYPE_P (TREE_TYPE (decl))
2525 : 406 : && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
2526 : 8 : decl = build_fold_indirect_ref (decl);
2527 : 390 : 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 : 374 : 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 : 390 : if (is_cnt)
2550 : 195 : 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 : 45598 : gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq)
2561 : : {
2562 : 45598 : return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE,
2563 : 45598 : NULL_TREE, NULL_TREE, NULL_TREE, seq);
2564 : : }
2565 : :
2566 : : /* Does the actual deep mapping. */
2567 : : void
2568 : 397 : 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 : 397 : (void) gfc_omp_deep_mapping_do (false, ctx, clause, tkind, data, sizes, kinds,
2574 : : offset_data, offset, seq);
2575 : 397 : }
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 : 3664 : gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
2583 : : {
2584 : 3664 : tree type = TREE_TYPE (decl);
2585 : 3664 : if (TREE_CODE (type) == REFERENCE_TYPE)
2586 : 1351 : type = TREE_TYPE (type);
2587 : 3664 : if (TREE_CODE (type) == POINTER_TYPE)
2588 : : {
2589 : 589 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
2590 : 589 : || GFC_DECL_GET_SCALAR_POINTER (decl))
2591 : : {
2592 : 150 : 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 : 3114 : if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
2601 : 5564 : && TYPE_STRING_FLAG (type))
2602 : : return false;
2603 : 3190 : if (INTEGRAL_TYPE_P (type)
2604 : 3190 : || SCALAR_FLOAT_TYPE_P (type)
2605 : 3190 : || COMPLEX_FLOAT_TYPE_P (type))
2606 : 2649 : 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 : 3556 : gfc_omp_scalar_target_p (tree decl)
2616 : : {
2617 : 3556 : return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
2618 : 3657 : && 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 : 1633308 : gfc_omp_disregard_value_expr (tree decl, bool shared)
2629 : : {
2630 : 1633308 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2631 : 1633308 : && 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 : 1630278 : 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 : 38390 : gfc_omp_private_debug_clause (tree decl, bool shared)
2662 : : {
2663 : 38390 : if (GFC_DECL_CRAY_POINTEE (decl))
2664 : : return true;
2665 : :
2666 : 38354 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2667 : 38354 : && 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 : 21674 : gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
2685 : : {
2686 : 21674 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
2687 : : {
2688 : 3970 : int r;
2689 : :
2690 : 3970 : gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
2691 : 9142 : for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
2692 : : {
2693 : 5172 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
2694 : 5172 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
2695 : 5172 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
2696 : : }
2697 : 3970 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
2698 : 3970 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
2699 : : }
2700 : 21674 : }
2701 : :
2702 : :
2703 : : static inline tree
2704 : 74056 : gfc_trans_add_clause (tree node, tree tail)
2705 : : {
2706 : 74056 : OMP_CLAUSE_CHAIN (node) = tail;
2707 : 74056 : return node;
2708 : : }
2709 : :
2710 : : static tree
2711 : 42903 : gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
2712 : : {
2713 : 42903 : 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 : 42721 : tree t = gfc_get_symbol_decl (sym);
2739 : 42721 : tree parent_decl;
2740 : 42721 : int parent_flag;
2741 : 42721 : bool return_value;
2742 : 42721 : bool alternate_entry;
2743 : 42721 : bool entry_master;
2744 : :
2745 : 42721 : return_value = sym->attr.function && sym->result == sym;
2746 : 167 : alternate_entry = sym->attr.function && sym->attr.entry
2747 : 42755 : && sym->result == sym;
2748 : 85442 : entry_master = sym->attr.result
2749 : 172 : && sym->ns->proc_name->attr.entry_master
2750 : 42733 : && !gfc_return_by_reference (sym->ns->proc_name);
2751 : 42721 : parent_decl = current_function_decl
2752 : 42721 : ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
2753 : :
2754 : 42721 : if ((t == parent_decl && return_value)
2755 : 42714 : || (sym->ns && sym->ns->proc_name
2756 : 42714 : && sym->ns->proc_name->backend_decl == parent_decl
2757 : 2173 : && (alternate_entry || entry_master)))
2758 : : parent_flag = 1;
2759 : : else
2760 : 42712 : 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 : 42721 : 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 : 42624 : 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 : 42592 : 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 : 11648 : 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 : 30049 : for (; namelist != NULL; namelist = namelist->next)
2800 : 18401 : if ((namelist->sym->attr.referenced || declare_simd)
2801 : 18401 : && namelist->sym->attr.flavor != FL_PARAMETER)
2802 : : {
2803 : 18396 : tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
2804 : 18396 : if (t != error_mark_node)
2805 : : {
2806 : 18396 : tree node;
2807 : 18396 : node = build_omp_clause (input_location, code);
2808 : 18396 : OMP_CLAUSE_DECL (node) = t;
2809 : 18396 : list = gfc_trans_add_clause (node, list);
2810 : :
2811 : 18396 : if (code == OMP_CLAUSE_LASTPRIVATE
2812 : 2864 : && namelist->u.lastprivate_conditional)
2813 : 88 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
2814 : : }
2815 : : }
2816 : 11648 : 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 : 3846 : gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list,
3138 : : locus where, bool mark_addressable)
3139 : : {
3140 : 3846 : omp_clause_code clause = OMP_CLAUSE_REDUCTION;
3141 : 3846 : 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 : 8636 : for (; namelist != NULL; namelist = namelist->next)
3157 : 4790 : if (namelist->sym->attr.referenced)
3158 : : {
3159 : 4790 : tree t = gfc_trans_omp_variable (namelist->sym, false);
3160 : 4790 : if (t != error_mark_node)
3161 : : {
3162 : 4790 : tree node = build_omp_clause (gfc_get_location (&namelist->where),
3163 : : clause);
3164 : 4790 : OMP_CLAUSE_DECL (node) = t;
3165 : 4790 : if (mark_addressable)
3166 : 38 : TREE_ADDRESSABLE (t) = 1;
3167 : 4790 : if (kind == OMP_LIST_REDUCTION_INSCAN)
3168 : 20 : OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
3169 : 4790 : if (kind == OMP_LIST_REDUCTION_TASK)
3170 : 91 : OMP_CLAUSE_REDUCTION_TASK (node) = 1;
3171 : 4790 : 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 : 197 : case OMP_REDUCTION_MINUS:
3177 : 197 : OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR;
3178 : 197 : 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 : 4790 : if (namelist->sym->attr.dimension
3216 : 4364 : || namelist->u.reduction_op == OMP_REDUCTION_USER
3217 : 4120 : || namelist->sym->attr.allocatable)
3218 : 683 : gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
3219 : 4790 : list = gfc_trans_add_clause (node, list);
3220 : : }
3221 : : }
3222 : 3846 : 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 : 3982 : 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 : 3982 : gfc_se se;
3252 : 3982 : tree ptr, ptr2;
3253 : 3982 : tree elemsz = NULL_TREE;
3254 : :
3255 : 3982 : gfc_init_se (&se, NULL);
3256 : 3982 : if (element)
3257 : : {
3258 : 174 : gfc_conv_expr_reference (&se, n->expr);
3259 : 174 : gfc_add_block_to_block (block, &se.pre);
3260 : 174 : 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 : 3982 : 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 : 3982 : if (element)
3277 : : {
3278 : 174 : if (!elemsz)
3279 : 174 : elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
3280 : 174 : 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 : 3982 : gcc_assert (se.post.head == NULL_TREE);
3307 : 3982 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3308 : 3982 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3309 : 3982 : ptr = fold_convert (ptrdiff_type_node, ptr);
3310 : :
3311 : 7702 : 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 : 4060 : && 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 : 3904 : 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 : 3982 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3345 : : {
3346 : 2709 : tree type = TREE_TYPE (decl);
3347 : 2709 : ptr2 = gfc_conv_descriptor_data_get (decl);
3348 : 2709 : node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3349 : 2709 : OMP_CLAUSE_DECL (node2) = decl;
3350 : 2709 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3351 : 2709 : if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE
3352 : 2708 : || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
3353 : 2499 : || op == EXEC_OMP_TARGET_EXIT_DATA
3354 : 5208 : || 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 : 2317 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
3364 : 2709 : node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
3365 : 2709 : OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
3366 : 2709 : 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 : 2709 : 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 : 3837 : ptr2 = fold_convert (ptrdiff_type_node, ptr2);
3404 : 3837 : 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 : 621 : 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 : 621 : if (!n2)
3482 : : return NULL;
3483 : :
3484 : 584 : 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 : 584 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE && n->expr->symtree)
3489 : 584 : use_sym = n->expr->symtree->n.sym;
3490 : :
3491 : 584 : *sym_based = false;
3492 : :
3493 : 584 : if (!use_sym)
3494 : : return n2;
3495 : :
3496 : 584 : if (!sym_rooted_nl)
3497 : : {
3498 : 276 : sym_rooted_nl = new hash_map<gfc_symbol *, gfc_omp_namelist *> ();
3499 : :
3500 : 1284 : for (; n2 != NULL; n2 = n2->next)
3501 : : {
3502 : 1008 : if (!n2->expr
3503 : 1007 : || n2->expr->expr_type != EXPR_VARIABLE
3504 : 1007 : || !n2->expr->symtree)
3505 : 1 : continue;
3506 : :
3507 : 1007 : gfc_omp_namelist *nl_copy = gfc_get_omp_namelist ();
3508 : 1007 : memcpy (nl_copy, n2, sizeof *nl_copy);
3509 : 1007 : nl_copy->u2.duplicate_of = n2;
3510 : 1007 : nl_copy->next = NULL;
3511 : :
3512 : 1007 : gfc_symbol *idx_sym = n2->expr->symtree->n.sym;
3513 : :
3514 : 1007 : bool existed;
3515 : 1007 : gfc_omp_namelist *&entry
3516 : 1007 : = sym_rooted_nl->get_or_insert (idx_sym, &existed);
3517 : 1007 : if (existed)
3518 : 674 : nl_copy->next = entry;
3519 : 1007 : entry = nl_copy;
3520 : : }
3521 : : }
3522 : :
3523 : 584 : gfc_omp_namelist **n2_sym = sym_rooted_nl->get (use_sym);
3524 : :
3525 : 584 : if (n2_sym)
3526 : : {
3527 : 584 : *sym_based = true;
3528 : 584 : return *n2_sym;
3529 : : }
3530 : :
3531 : : return NULL;
3532 : : }
3533 : :
3534 : : static tree
3535 : 31526 : gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
3536 : : locus where, bool declare_simd = false,
3537 : : bool openacc = false, gfc_exec_op op = EXEC_NOP)
3538 : : {
3539 : 31526 : tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
3540 : 31526 : tree iterator = NULL_TREE;
3541 : 31526 : tree tree_block = NULL_TREE;
3542 : 31526 : stmtblock_t iter_block;
3543 : 31526 : int list, ifc;
3544 : 31526 : enum omp_clause_code clause_code;
3545 : 31526 : gfc_omp_namelist *prev = NULL;
3546 : 31526 : gfc_se se;
3547 : :
3548 : 31526 : if (clauses == NULL)
3549 : : return NULL_TREE;
3550 : :
3551 : 31514 : hash_map<gfc_symbol *, gfc_omp_namelist *> *sym_rooted_nl = NULL;
3552 : :
3553 : 1260560 : for (list = 0; list < OMP_LIST_NUM; list++)
3554 : : {
3555 : 1229046 : gfc_omp_namelist *n = clauses->lists[list];
3556 : :
3557 : 1229046 : if (n == NULL)
3558 : 1201465 : continue;
3559 : 27581 : switch (list)
3560 : : {
3561 : 3846 : case OMP_LIST_REDUCTION:
3562 : 3846 : case OMP_LIST_REDUCTION_INSCAN:
3563 : 3846 : case OMP_LIST_REDUCTION_TASK:
3564 : 3846 : case OMP_LIST_IN_REDUCTION:
3565 : 3846 : case OMP_LIST_TASK_REDUCTION:
3566 : : /* An OpenACC async clause indicates the need to set reduction
3567 : : arguments addressable, to allow asynchronous copy-out. */
3568 : 3846 : omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses,
3569 : 3846 : where, clauses->async);
3570 : 3846 : break;
3571 : 6458 : case OMP_LIST_PRIVATE:
3572 : 6458 : clause_code = OMP_CLAUSE_PRIVATE;
3573 : 6458 : goto add_clause;
3574 : 1067 : case OMP_LIST_SHARED:
3575 : 1067 : clause_code = OMP_CLAUSE_SHARED;
3576 : 1067 : goto add_clause;
3577 : 1038 : case OMP_LIST_FIRSTPRIVATE:
3578 : 1038 : clause_code = OMP_CLAUSE_FIRSTPRIVATE;
3579 : 1038 : goto add_clause;
3580 : 1661 : case OMP_LIST_LASTPRIVATE:
3581 : 1661 : clause_code = OMP_CLAUSE_LASTPRIVATE;
3582 : 1661 : goto add_clause;
3583 : 96 : case OMP_LIST_COPYIN:
3584 : 96 : clause_code = OMP_CLAUSE_COPYIN;
3585 : 96 : goto add_clause;
3586 : 74 : case OMP_LIST_COPYPRIVATE:
3587 : 74 : clause_code = OMP_CLAUSE_COPYPRIVATE;
3588 : 74 : goto add_clause;
3589 : 61 : case OMP_LIST_UNIFORM:
3590 : 61 : clause_code = OMP_CLAUSE_UNIFORM;
3591 : 61 : goto add_clause;
3592 : 51 : case OMP_LIST_USE_DEVICE:
3593 : 51 : case OMP_LIST_USE_DEVICE_PTR:
3594 : 51 : clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
3595 : 51 : goto add_clause;
3596 : 922 : case OMP_LIST_USE_DEVICE_ADDR:
3597 : 922 : clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
3598 : 922 : goto add_clause;
3599 : 43 : case OMP_LIST_IS_DEVICE_PTR:
3600 : 43 : clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
3601 : 43 : goto add_clause;
3602 : 100 : case OMP_LIST_HAS_DEVICE_ADDR:
3603 : 100 : clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
3604 : 100 : goto add_clause;
3605 : 2 : case OMP_LIST_NONTEMPORAL:
3606 : 2 : clause_code = OMP_CLAUSE_NONTEMPORAL;
3607 : 2 : goto add_clause;
3608 : 9 : case OMP_LIST_SCAN_IN:
3609 : 9 : clause_code = OMP_CLAUSE_INCLUSIVE;
3610 : 9 : goto add_clause;
3611 : 7 : case OMP_LIST_SCAN_EX:
3612 : 7 : clause_code = OMP_CLAUSE_EXCLUSIVE;
3613 : 7 : goto add_clause;
3614 : 4 : case OMP_LIST_USE:
3615 : 4 : clause_code = OMP_CLAUSE_USE;
3616 : 4 : goto add_clause;
3617 : 55 : case OMP_LIST_INTEROP:
3618 : 55 : clause_code = OMP_CLAUSE_INTEROP;
3619 : 55 : goto add_clause;
3620 : :
3621 : 11648 : add_clause:
3622 : 11648 : omp_clauses
3623 : 11648 : = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
3624 : : declare_simd);
3625 : 11648 : break;
3626 : :
3627 : : case OMP_LIST_DESTROY:
3628 : 12 : for (; n != NULL; n = n->next)
3629 : 9 : if (n->sym->attr.referenced)
3630 : : {
3631 : 9 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3632 : 9 : if (t != error_mark_node)
3633 : : {
3634 : 9 : tree node
3635 : 9 : = build_omp_clause (input_location, OMP_CLAUSE_DESTROY);
3636 : 9 : OMP_CLAUSE_DECL (node) = t;
3637 : 9 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3638 : 9 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3639 : : }
3640 : : }
3641 : : break;
3642 : :
3643 : : case OMP_LIST_INIT:
3644 : : {
3645 : : tree pref_type = NULL_TREE;
3646 : : const char *last = NULL;
3647 : 32 : for (; n != NULL; n = n->next)
3648 : 26 : if (n->sym->attr.referenced)
3649 : : {
3650 : 26 : tree t = gfc_trans_omp_variable (n->sym, false);
3651 : 26 : if (t == error_mark_node)
3652 : 0 : continue;
3653 : 26 : tree node = build_omp_clause (input_location,
3654 : : OMP_CLAUSE_INIT);
3655 : 26 : OMP_CLAUSE_DECL (node) = t;
3656 : 26 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3657 : 26 : if (n->u.init.target)
3658 : 19 : OMP_CLAUSE_INIT_TARGET (node) = 1;
3659 : 26 : if (n->u.init.targetsync)
3660 : 10 : OMP_CLAUSE_INIT_TARGETSYNC (node) = 1;
3661 : 26 : if (last != n->u2.init_interop)
3662 : : {
3663 : 6 : last = n->u2.init_interop;
3664 : 6 : if (n->u2.init_interop == NULL)
3665 : : pref_type = NULL_TREE;
3666 : : else
3667 : : {
3668 : 5 : pref_type = build_string (n->u.init.len,
3669 : : n->u2.init_interop);
3670 : 5 : TREE_TYPE (pref_type)
3671 : 10 : = build_array_type_nelts (unsigned_char_type_node,
3672 : 5 : n->u.init.len);
3673 : : }
3674 : : }
3675 : 26 : OMP_CLAUSE_INIT_PREFER_TYPE (node) = pref_type;
3676 : 26 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3677 : : }
3678 : : break;
3679 : : }
3680 : :
3681 : : case OMP_LIST_ALIGNED:
3682 : 256 : for (; n != NULL; n = n->next)
3683 : 149 : if (n->sym->attr.referenced || declare_simd)
3684 : : {
3685 : 149 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3686 : 149 : if (t != error_mark_node)
3687 : : {
3688 : 149 : tree node = build_omp_clause (input_location,
3689 : : OMP_CLAUSE_ALIGNED);
3690 : 149 : OMP_CLAUSE_DECL (node) = t;
3691 : 149 : if (n->expr)
3692 : : {
3693 : 148 : tree alignment_var;
3694 : :
3695 : 148 : if (declare_simd)
3696 : 5 : alignment_var = gfc_conv_constant_to_tree (n->expr);
3697 : : else
3698 : : {
3699 : 143 : gfc_init_se (&se, NULL);
3700 : 143 : gfc_conv_expr (&se, n->expr);
3701 : 143 : gfc_add_block_to_block (block, &se.pre);
3702 : 143 : alignment_var = gfc_evaluate_now (se.expr, block);
3703 : 143 : gfc_add_block_to_block (block, &se.post);
3704 : : }
3705 : 148 : OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
3706 : : }
3707 : 149 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3708 : : }
3709 : : }
3710 : : break;
3711 : : case OMP_LIST_ALLOCATE:
3712 : : {
3713 : : tree allocator_ = NULL_TREE;
3714 : : gfc_expr *alloc_expr = NULL;
3715 : 582 : for (; n != NULL; n = n->next)
3716 : 377 : if (n->sym->attr.referenced)
3717 : : {
3718 : 377 : tree t = gfc_trans_omp_variable (n->sym, false);
3719 : 377 : if (t != error_mark_node)
3720 : : {
3721 : 377 : tree node = build_omp_clause (input_location,
3722 : : OMP_CLAUSE_ALLOCATE);
3723 : 377 : OMP_CLAUSE_DECL (node) = t;
3724 : 377 : if (n->u2.allocator)
3725 : : {
3726 : 242 : if (alloc_expr != n->u2.allocator)
3727 : : {
3728 : 125 : gfc_init_se (&se, NULL);
3729 : 125 : gfc_conv_expr (&se, n->u2.allocator);
3730 : 125 : gfc_add_block_to_block (block, &se.pre);
3731 : 125 : allocator_ = gfc_evaluate_now (se.expr, block);
3732 : 125 : gfc_add_block_to_block (block, &se.post);
3733 : : }
3734 : 242 : OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
3735 : : }
3736 : 377 : alloc_expr = n->u2.allocator;
3737 : 377 : if (n->u.align)
3738 : : {
3739 : 3 : tree align_;
3740 : 3 : gfc_init_se (&se, NULL);
3741 : 3 : gfc_conv_expr (&se, n->u.align);
3742 : 3 : gcc_assert (CONSTANT_CLASS_P (se.expr)
3743 : : && se.pre.head == NULL
3744 : : && se.post.head == NULL);
3745 : 3 : align_ = se.expr;
3746 : 3 : OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
3747 : : }
3748 : 377 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3749 : : }
3750 : : }
3751 : : else
3752 : 0 : alloc_expr = n->u2.allocator;
3753 : : }
3754 : : break;
3755 : : case OMP_LIST_LINEAR:
3756 : : {
3757 : : gfc_expr *last_step_expr = NULL;
3758 : : tree last_step = NULL_TREE;
3759 : : bool last_step_parm = false;
3760 : :
3761 : 1288 : for (; n != NULL; n = n->next)
3762 : : {
3763 : 795 : if (n->expr)
3764 : : {
3765 : 776 : last_step_expr = n->expr;
3766 : 776 : last_step = NULL_TREE;
3767 : 776 : last_step_parm = false;
3768 : : }
3769 : 795 : if (n->sym->attr.referenced || declare_simd)
3770 : : {
3771 : 795 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3772 : 795 : if (t != error_mark_node)
3773 : : {
3774 : 795 : tree node = build_omp_clause (input_location,
3775 : : OMP_CLAUSE_LINEAR);
3776 : 795 : OMP_CLAUSE_DECL (node) = t;
3777 : 795 : omp_clause_linear_kind kind;
3778 : 795 : switch (n->u.linear.op)
3779 : : {
3780 : : case OMP_LINEAR_DEFAULT:
3781 : : kind = OMP_CLAUSE_LINEAR_DEFAULT;
3782 : : break;
3783 : : case OMP_LINEAR_REF:
3784 : : kind = OMP_CLAUSE_LINEAR_REF;
3785 : : break;
3786 : : case OMP_LINEAR_VAL:
3787 : : kind = OMP_CLAUSE_LINEAR_VAL;
3788 : : break;
3789 : : case OMP_LINEAR_UVAL:
3790 : : kind = OMP_CLAUSE_LINEAR_UVAL;
3791 : : break;
3792 : 0 : default:
3793 : 0 : gcc_unreachable ();
3794 : : }
3795 : 795 : OMP_CLAUSE_LINEAR_KIND (node) = kind;
3796 : 795 : OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node)
3797 : 795 : = n->u.linear.old_modifier;
3798 : 795 : if (last_step_expr && last_step == NULL_TREE)
3799 : : {
3800 : 776 : if (!declare_simd)
3801 : : {
3802 : 695 : gfc_init_se (&se, NULL);
3803 : 695 : gfc_conv_expr (&se, last_step_expr);
3804 : 695 : gfc_add_block_to_block (block, &se.pre);
3805 : 695 : last_step = gfc_evaluate_now (se.expr, block);
3806 : 695 : gfc_add_block_to_block (block, &se.post);
3807 : : }
3808 : 81 : else if (last_step_expr->expr_type == EXPR_VARIABLE)
3809 : : {
3810 : 2 : gfc_symbol *s = last_step_expr->symtree->n.sym;
3811 : 2 : last_step = gfc_trans_omp_variable (s, true);
3812 : 2 : last_step_parm = true;
3813 : : }
3814 : : else
3815 : 79 : last_step
3816 : 79 : = gfc_conv_constant_to_tree (last_step_expr);
3817 : : }
3818 : 795 : if (last_step_parm)
3819 : : {
3820 : 2 : OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
3821 : 2 : OMP_CLAUSE_LINEAR_STEP (node) = last_step;
3822 : : }
3823 : : else
3824 : : {
3825 : 793 : if (kind == OMP_CLAUSE_LINEAR_REF)
3826 : : {
3827 : 34 : tree type;
3828 : 34 : if (n->sym->attr.flavor == FL_PROCEDURE)
3829 : : {
3830 : 0 : type = gfc_get_function_type (n->sym);
3831 : 0 : type = build_pointer_type (type);
3832 : : }
3833 : : else
3834 : 34 : type = gfc_sym_type (n->sym);
3835 : 34 : if (POINTER_TYPE_P (type))
3836 : 34 : type = TREE_TYPE (type);
3837 : : /* Otherwise to be determined what exactly
3838 : : should be done. */
3839 : 34 : tree t = fold_convert (sizetype, last_step);
3840 : 34 : t = size_binop (MULT_EXPR, t,
3841 : : TYPE_SIZE_UNIT (type));
3842 : 34 : OMP_CLAUSE_LINEAR_STEP (node) = t;
3843 : : }
3844 : : else
3845 : : {
3846 : 759 : tree type
3847 : 759 : = gfc_typenode_for_spec (&n->sym->ts);
3848 : 759 : OMP_CLAUSE_LINEAR_STEP (node)
3849 : 1518 : = fold_convert (type, last_step);
3850 : : }
3851 : : }
3852 : 795 : if (n->sym->attr.dimension || n->sym->attr.allocatable)
3853 : 222 : OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
3854 : 795 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3855 : : }
3856 : : }
3857 : : }
3858 : : }
3859 : : break;
3860 : : case OMP_LIST_AFFINITY:
3861 : : case OMP_LIST_DEPEND:
3862 : : iterator = NULL_TREE;
3863 : : prev = NULL;
3864 : : prev_clauses = omp_clauses;
3865 : 1574 : for (; n != NULL; n = n->next)
3866 : : {
3867 : 853 : if (iterator && prev->u2.ns != n->u2.ns)
3868 : : {
3869 : 12 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
3870 : 12 : TREE_VEC_ELT (iterator, 5) = tree_block;
3871 : 26 : for (tree c = omp_clauses; c != prev_clauses;
3872 : 14 : c = OMP_CLAUSE_CHAIN (c))
3873 : 28 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
3874 : 14 : OMP_CLAUSE_DECL (c));
3875 : : prev_clauses = omp_clauses;
3876 : : iterator = NULL_TREE;
3877 : : }
3878 : 853 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
3879 : : {
3880 : 43 : gfc_init_block (&iter_block);
3881 : 43 : tree_block = make_node (BLOCK);
3882 : 43 : TREE_USED (tree_block) = 1;
3883 : 43 : BLOCK_VARS (tree_block) = NULL_TREE;
3884 : 43 : iterator = handle_iterator (n->u2.ns, block,
3885 : : tree_block);
3886 : : }
3887 : 853 : if (!iterator)
3888 : 801 : gfc_init_block (&iter_block);
3889 : 853 : prev = n;
3890 : 853 : if (list == OMP_LIST_DEPEND
3891 : 827 : && (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
3892 : 827 : || n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST))
3893 : : {
3894 : 227 : tree vec = NULL_TREE;
3895 : 227 : unsigned int i;
3896 : 227 : bool is_depend
3897 : : = n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST;
3898 : 227 : for (i = 0; ; i++)
3899 : : {
3900 : 1218 : tree addend = integer_zero_node, t;
3901 : 1218 : bool neg = false;
3902 : 1218 : if (n->sym && n->expr)
3903 : : {
3904 : 558 : addend = gfc_conv_constant_to_tree (n->expr);
3905 : 558 : if (TREE_CODE (addend) == INTEGER_CST
3906 : 558 : && tree_int_cst_sgn (addend) == -1)
3907 : : {
3908 : 407 : neg = true;
3909 : 407 : addend = const_unop (NEGATE_EXPR,
3910 : 407 : TREE_TYPE (addend), addend);
3911 : : }
3912 : : }
3913 : :
3914 : 1218 : if (n->sym == NULL)
3915 : 0 : t = null_pointer_node; /* "omp_cur_iteration - 1". */
3916 : : else
3917 : 1218 : t = gfc_trans_omp_variable (n->sym, false);
3918 : 1218 : if (t != error_mark_node)
3919 : : {
3920 : 1218 : if (i < vec_safe_length (doacross_steps)
3921 : 426 : && !integer_zerop (addend)
3922 : 630 : && (*doacross_steps)[i])
3923 : : {
3924 : 204 : tree step = (*doacross_steps)[i];
3925 : 204 : addend = fold_convert (TREE_TYPE (step), addend);
3926 : 204 : addend = build2 (TRUNC_DIV_EXPR,
3927 : 204 : TREE_TYPE (step), addend, step);
3928 : : }
3929 : 1218 : vec = tree_cons (addend, t, vec);
3930 : 1218 : if (neg)
3931 : 407 : OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
3932 : : }
3933 : 1218 : if (n->next == NULL
3934 : 1057 : || n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
3935 : : break;
3936 : 991 : n = n->next;
3937 : 991 : }
3938 : 227 : if (vec == NULL_TREE)
3939 : 0 : continue;
3940 : :
3941 : 227 : tree node = build_omp_clause (input_location,
3942 : : OMP_CLAUSE_DOACROSS);
3943 : 227 : OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
3944 : 227 : OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend;
3945 : 227 : OMP_CLAUSE_DECL (node) = nreverse (vec);
3946 : 227 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3947 : 227 : continue;
3948 : 227 : }
3949 : :
3950 : 626 : if (n->sym && !n->sym->attr.referenced)
3951 : 0 : continue;
3952 : :
3953 : 652 : tree node = build_omp_clause (input_location,
3954 : : list == OMP_LIST_DEPEND
3955 : : ? OMP_CLAUSE_DEPEND
3956 : : : OMP_CLAUSE_AFFINITY);
3957 : 626 : if (n->sym == NULL) /* omp_all_memory */
3958 : 9 : OMP_CLAUSE_DECL (node) = null_pointer_node;
3959 : 617 : else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
3960 : : {
3961 : 404 : tree decl = gfc_trans_omp_variable (n->sym, false);
3962 : 404 : if (gfc_omp_privatize_by_reference (decl))
3963 : 62 : decl = build_fold_indirect_ref (decl);
3964 : 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
3965 : : {
3966 : 23 : decl = gfc_conv_descriptor_data_get (decl);
3967 : 23 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
3968 : 23 : decl = build_fold_indirect_ref (decl);
3969 : : }
3970 : 381 : else if (n->sym->attr.allocatable || n->sym->attr.pointer)
3971 : 22 : decl = build_fold_indirect_ref (decl);
3972 : 359 : else if (DECL_P (decl))
3973 : 326 : TREE_ADDRESSABLE (decl) = 1;
3974 : 404 : OMP_CLAUSE_DECL (node) = decl;
3975 : 404 : }
3976 : : else
3977 : : {
3978 : 213 : tree ptr;
3979 : 213 : gfc_init_se (&se, NULL);
3980 : 213 : if (n->expr->ref->u.ar.type == AR_ELEMENT)
3981 : : {
3982 : 133 : gfc_conv_expr_reference (&se, n->expr);
3983 : 133 : ptr = se.expr;
3984 : : }
3985 : : else
3986 : : {
3987 : 80 : gfc_conv_expr_descriptor (&se, n->expr);
3988 : 80 : ptr = gfc_conv_array_data (se.expr);
3989 : : }
3990 : 213 : gfc_add_block_to_block (&iter_block, &se.pre);
3991 : 213 : gfc_add_block_to_block (&iter_block, &se.post);
3992 : 213 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
3993 : 213 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
3994 : : }
3995 : 626 : if (list == OMP_LIST_DEPEND)
3996 : 600 : switch (n->u.depend_doacross_op)
3997 : : {
3998 : 227 : case OMP_DEPEND_IN:
3999 : 227 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
4000 : 227 : break;
4001 : 256 : case OMP_DEPEND_OUT:
4002 : 256 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
4003 : 256 : break;
4004 : 55 : case OMP_DEPEND_INOUT:
4005 : 55 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
4006 : 55 : break;
4007 : 9 : case OMP_DEPEND_INOUTSET:
4008 : 9 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET;
4009 : 9 : break;
4010 : 15 : case OMP_DEPEND_MUTEXINOUTSET:
4011 : 15 : OMP_CLAUSE_DEPEND_KIND (node)
4012 : 15 : = OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
4013 : 15 : break;
4014 : 38 : case OMP_DEPEND_DEPOBJ:
4015 : 38 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
4016 : 38 : break;
4017 : 0 : default:
4018 : 0 : gcc_unreachable ();
4019 : : }
4020 : 626 : if (!iterator)
4021 : 574 : gfc_add_block_to_block (block, &iter_block);
4022 : 626 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4023 : : }
4024 : 721 : if (iterator)
4025 : : {
4026 : 31 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4027 : 31 : TREE_VEC_ELT (iterator, 5) = tree_block;
4028 : 70 : for (tree c = omp_clauses; c != prev_clauses;
4029 : 39 : c = OMP_CLAUSE_CHAIN (c))
4030 : 78 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
4031 : 39 : OMP_CLAUSE_DECL (c));
4032 : : }
4033 : : break;
4034 : : case OMP_LIST_MAP:
4035 : 23739 : for (; n != NULL; n = n->next)
4036 : : {
4037 : 14974 : if (!n->sym->attr.referenced
4038 : 14974 : || n->sym->attr.flavor == FL_PARAMETER)
4039 : 289 : continue;
4040 : :
4041 : 14965 : location_t map_loc = gfc_get_location (&n->where);
4042 : 14965 : bool always_modifier = false;
4043 : 14965 : tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4044 : 14965 : tree node2 = NULL_TREE;
4045 : 14965 : tree node3 = NULL_TREE;
4046 : 14965 : tree node4 = NULL_TREE;
4047 : 14965 : tree node5 = NULL_TREE;
4048 : :
4049 : : /* OpenMP: automatically map pointer targets with the pointer;
4050 : : hence, always update the descriptor/pointer itself. */
4051 : 14965 : if (!openacc
4052 : 14965 : && ((n->expr == NULL && n->sym->attr.pointer)
4053 : 14177 : || (n->expr && gfc_expr_attr (n->expr).pointer)))
4054 : 1393 : always_modifier = true;
4055 : :
4056 : 14965 : if (n->u.map.readonly)
4057 : 22 : OMP_CLAUSE_MAP_READONLY (node) = 1;
4058 : :
4059 : 14965 : switch (n->u.map.op)
4060 : : {
4061 : 1073 : case OMP_MAP_ALLOC:
4062 : 1073 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
4063 : 1073 : break;
4064 : 64 : case OMP_MAP_IF_PRESENT:
4065 : 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
4066 : 64 : break;
4067 : 62 : case OMP_MAP_ATTACH:
4068 : 62 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
4069 : 62 : break;
4070 : 4094 : case OMP_MAP_TO:
4071 : 4094 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
4072 : 4094 : break;
4073 : 2883 : case OMP_MAP_FROM:
4074 : 2883 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
4075 : 2883 : break;
4076 : 4350 : case OMP_MAP_TOFROM:
4077 : 4350 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
4078 : 4350 : break;
4079 : 32 : case OMP_MAP_ALWAYS_TO:
4080 : 32 : always_modifier = true;
4081 : 32 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
4082 : 32 : break;
4083 : 14 : case OMP_MAP_ALWAYS_FROM:
4084 : 14 : always_modifier = true;
4085 : 14 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
4086 : 14 : break;
4087 : 171 : case OMP_MAP_ALWAYS_TOFROM:
4088 : 171 : always_modifier = true;
4089 : 171 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
4090 : 171 : break;
4091 : 6 : case OMP_MAP_PRESENT_ALLOC:
4092 : 6 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC);
4093 : 6 : break;
4094 : 13 : case OMP_MAP_PRESENT_TO:
4095 : 13 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO);
4096 : 13 : break;
4097 : 4 : case OMP_MAP_PRESENT_FROM:
4098 : 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM);
4099 : 4 : break;
4100 : 2 : case OMP_MAP_PRESENT_TOFROM:
4101 : 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM);
4102 : 2 : break;
4103 : 8 : case OMP_MAP_ALWAYS_PRESENT_TO:
4104 : 8 : always_modifier = true;
4105 : 8 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO);
4106 : 8 : break;
4107 : 4 : case OMP_MAP_ALWAYS_PRESENT_FROM:
4108 : 4 : always_modifier = true;
4109 : 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM);
4110 : 4 : break;
4111 : 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
4112 : 2 : always_modifier = true;
4113 : 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM);
4114 : 2 : break;
4115 : 426 : case OMP_MAP_RELEASE:
4116 : 426 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
4117 : 426 : break;
4118 : 56 : case OMP_MAP_DELETE:
4119 : 56 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
4120 : 56 : break;
4121 : 40 : case OMP_MAP_DETACH:
4122 : 40 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
4123 : 40 : break;
4124 : 64 : case OMP_MAP_FORCE_ALLOC:
4125 : 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
4126 : 64 : break;
4127 : 465 : case OMP_MAP_FORCE_TO:
4128 : 465 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
4129 : 465 : break;
4130 : 577 : case OMP_MAP_FORCE_FROM:
4131 : 577 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
4132 : 577 : break;
4133 : 0 : case OMP_MAP_FORCE_TOFROM:
4134 : 0 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
4135 : 0 : break;
4136 : 545 : case OMP_MAP_FORCE_PRESENT:
4137 : 545 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
4138 : 545 : break;
4139 : 10 : case OMP_MAP_FORCE_DEVICEPTR:
4140 : 10 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
4141 : 10 : break;
4142 : 0 : default:
4143 : 0 : gcc_unreachable ();
4144 : : }
4145 : :
4146 : 14965 : tree decl = gfc_trans_omp_variable (n->sym, false);
4147 : 14965 : if (DECL_P (decl))
4148 : 14965 : TREE_ADDRESSABLE (decl) = 1;
4149 : :
4150 : 14965 : gfc_ref *lastref = NULL;
4151 : :
4152 : 14965 : if (n->expr)
4153 : 13078 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4154 : 7718 : if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
4155 : 7718 : lastref = ref;
4156 : :
4157 : 5360 : bool allocatable = false, pointer = false;
4158 : :
4159 : 5360 : if (lastref && lastref->type == REF_COMPONENT)
4160 : : {
4161 : 457 : gfc_component *c = lastref->u.c.component;
4162 : :
4163 : 457 : if (c->ts.type == BT_CLASS)
4164 : : {
4165 : 24 : pointer = CLASS_DATA (c)->attr.class_pointer;
4166 : 24 : allocatable = CLASS_DATA (c)->attr.allocatable;
4167 : : }
4168 : : else
4169 : : {
4170 : 433 : pointer = c->attr.pointer;
4171 : 433 : allocatable = c->attr.allocatable;
4172 : : }
4173 : : }
4174 : :
4175 : 14965 : if (n->expr == NULL
4176 : 5360 : || (n->expr->ref->type == REF_ARRAY
4177 : 3549 : && n->expr->ref->u.ar.type == AR_FULL))
4178 : : {
4179 : 9605 : gomp_map_kind map_kind;
4180 : 9605 : tree type = TREE_TYPE (decl);
4181 : 9605 : if (n->sym->ts.type == BT_CHARACTER
4182 : 218 : && n->sym->ts.deferred
4183 : 92 : && (n->sym->attr.omp_declare_target
4184 : 84 : || n->sym->attr.omp_declare_target_link
4185 : 84 : || n->sym->attr.omp_declare_target_local)
4186 : 8 : && (always_modifier || n->sym->attr.pointer)
4187 : 8 : && op != EXEC_OMP_TARGET_EXIT_DATA
4188 : 4 : && n->u.map.op != OMP_MAP_DELETE
4189 : 4 : && n->u.map.op != OMP_MAP_RELEASE)
4190 : : {
4191 : 4 : gcc_assert (n->sym->ts.u.cl->backend_decl);
4192 : 4 : node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4193 : 4 : OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
4194 : 4 : OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
4195 : 4 : OMP_CLAUSE_SIZE (node5)
4196 : 8 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4197 : : }
4198 : :
4199 : 9605 : tree present = gfc_omp_check_optional_argument (decl, true);
4200 : 9605 : if (openacc && n->sym->ts.type == BT_CLASS)
4201 : : {
4202 : 60 : if (n->sym->attr.optional)
4203 : 0 : sorry_at (gfc_get_location (&n->where),
4204 : : "optional class parameter");
4205 : 60 : tree ptr = gfc_class_data_get (decl);
4206 : 60 : ptr = build_fold_indirect_ref (ptr);
4207 : 60 : OMP_CLAUSE_DECL (node) = ptr;
4208 : 60 : OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
4209 : 60 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4210 : 60 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
4211 : 60 : OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
4212 : 60 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4213 : 60 : goto finalize_map_clause;
4214 : : }
4215 : 9545 : else if (POINTER_TYPE_P (type)
4216 : 9545 : && (gfc_omp_privatize_by_reference (decl)
4217 : 530 : || GFC_DECL_GET_SCALAR_POINTER (decl)
4218 : 347 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
4219 : 84 : || GFC_DECL_CRAY_POINTEE (decl)
4220 : 84 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
4221 : 84 : || (n->sym->ts.type == BT_DERIVED
4222 : 8 : && (n->sym->ts.u.derived->ts.f90_type
4223 : : != BT_VOID))))
4224 : : {
4225 : 3406 : tree orig_decl = decl;
4226 : :
4227 : : /* For nonallocatable, nonpointer arrays, a temporary
4228 : : variable is generated, but this one is only defined if
4229 : : the variable is present; hence, we now set it to NULL
4230 : : to avoid accessing undefined variables. We cannot use
4231 : : a temporary variable here as otherwise the replacement
4232 : : of the variables in omp-low.cc will not work. */
4233 : 3406 : if (present && GFC_ARRAY_TYPE_P (type))
4234 : : {
4235 : 284 : tree tmp = fold_build2_loc (input_location,
4236 : : MODIFY_EXPR,
4237 : : void_type_node, decl,
4238 : : null_pointer_node);
4239 : 284 : tree cond = fold_build1_loc (input_location,
4240 : : TRUTH_NOT_EXPR,
4241 : : boolean_type_node,
4242 : : present);
4243 : 284 : gfc_add_expr_to_block (block,
4244 : : build3_loc (input_location,
4245 : : COND_EXPR,
4246 : : void_type_node,
4247 : : cond, tmp,
4248 : : NULL_TREE));
4249 : : }
4250 : : /* For descriptor types, the unmapping happens below. */
4251 : 3406 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4252 : 3406 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4253 : : {
4254 : 3406 : enum gomp_map_kind gmk = GOMP_MAP_POINTER;
4255 : 3406 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4256 : 57 : && n->u.map.op == OMP_MAP_DELETE)
4257 : : gmk = GOMP_MAP_DELETE;
4258 : 52 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4259 : 52 : gmk = GOMP_MAP_RELEASE;
4260 : 3406 : tree size;
4261 : 3406 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4262 : 57 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4263 : : else
4264 : 3349 : size = size_int (0);
4265 : 3406 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4266 : 3406 : OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
4267 : 3406 : OMP_CLAUSE_DECL (node4) = decl;
4268 : 3406 : OMP_CLAUSE_SIZE (node4) = size;
4269 : : }
4270 : 3406 : decl = build_fold_indirect_ref (decl);
4271 : 3406 : if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
4272 : 2179 : || gfc_omp_is_optional_argument (orig_decl))
4273 : 4458 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
4274 : 2109 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
4275 : : {
4276 : 408 : enum gomp_map_kind gmk;
4277 : 408 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4278 : 8 : && n->u.map.op == OMP_MAP_DELETE)
4279 : : gmk = GOMP_MAP_DELETE;
4280 : 6 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4281 : : gmk = GOMP_MAP_RELEASE;
4282 : : else
4283 : : gmk = GOMP_MAP_POINTER;
4284 : 408 : tree size;
4285 : 408 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4286 : 8 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4287 : : else
4288 : 400 : size = size_int (0);
4289 : 408 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4290 : 408 : OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
4291 : 408 : OMP_CLAUSE_DECL (node3) = decl;
4292 : 408 : OMP_CLAUSE_SIZE (node3) = size;
4293 : 408 : decl = build_fold_indirect_ref (decl);
4294 : : }
4295 : : }
4296 : 9545 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4297 : : {
4298 : 1396 : tree type = TREE_TYPE (decl);
4299 : 1396 : tree ptr = gfc_conv_descriptor_data_get (decl);
4300 : 1396 : if (present)
4301 : 309 : ptr = gfc_build_cond_assign_expr (block, present, ptr,
4302 : : null_pointer_node);
4303 : 1396 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4304 : 1396 : ptr = build_fold_indirect_ref (ptr);
4305 : 1396 : OMP_CLAUSE_DECL (node) = ptr;
4306 : 1396 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4307 : 1396 : OMP_CLAUSE_DECL (node2) = decl;
4308 : 1396 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
4309 : 1396 : if (n->u.map.op == OMP_MAP_DELETE)
4310 : : map_kind = GOMP_MAP_DELETE;
4311 : 1369 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
4312 : 1308 : || n->u.map.op == OMP_MAP_RELEASE)
4313 : : map_kind = GOMP_MAP_RELEASE;
4314 : : else
4315 : 1396 : map_kind = GOMP_MAP_TO_PSET;
4316 : 1396 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
4317 : :
4318 : 1396 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4319 : 1308 : && n->u.map.op != OMP_MAP_DELETE
4320 : 1308 : && n->u.map.op != OMP_MAP_RELEASE)
4321 : : {
4322 : 1260 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4323 : 1260 : if (present)
4324 : : {
4325 : 309 : ptr = gfc_conv_descriptor_data_get (decl);
4326 : 309 : ptr = gfc_build_addr_expr (NULL, ptr);
4327 : 309 : ptr = gfc_build_cond_assign_expr (
4328 : : block, present, ptr, null_pointer_node);
4329 : 309 : ptr = build_fold_indirect_ref (ptr);
4330 : 309 : OMP_CLAUSE_DECL (node3) = ptr;
4331 : : }
4332 : : else
4333 : 951 : OMP_CLAUSE_DECL (node3)
4334 : 1902 : = gfc_conv_descriptor_data_get (decl);
4335 : 1260 : OMP_CLAUSE_SIZE (node3) = size_int (0);
4336 : :
4337 : 1260 : if (n->u.map.op == OMP_MAP_ATTACH)
4338 : : {
4339 : : /* Standalone attach clauses used with arrays with
4340 : : descriptors must copy the descriptor to the
4341 : : target, else they won't have anything to
4342 : : perform the attachment onto (see OpenACC 2.6,
4343 : : "2.6.3. Data Structures with Pointers"). */
4344 : 7 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
4345 : : /* We don't want to map PTR at all in this case,
4346 : : so delete its node and shuffle the others
4347 : : down. */
4348 : 7 : node = node2;
4349 : 7 : node2 = node3;
4350 : 7 : node3 = NULL;
4351 : 7 : goto finalize_map_clause;
4352 : : }
4353 : 1253 : else if (n->u.map.op == OMP_MAP_DETACH)
4354 : : {
4355 : 2 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
4356 : : /* Similarly to above, we don't want to unmap PTR
4357 : : here. */
4358 : 2 : node = node2;
4359 : 2 : node2 = node3;
4360 : 2 : node3 = NULL;
4361 : 2 : goto finalize_map_clause;
4362 : : }
4363 : : else
4364 : 2034 : OMP_CLAUSE_SET_MAP_KIND (node3,
4365 : : always_modifier
4366 : : ? GOMP_MAP_ALWAYS_POINTER
4367 : : : GOMP_MAP_POINTER);
4368 : : }
4369 : :
4370 : : /* We have to check for n->sym->attr.dimension because
4371 : : of scalar coarrays. */
4372 : 1387 : if ((n->sym->attr.pointer || n->sym->attr.allocatable)
4373 : 1387 : && n->sym->attr.dimension)
4374 : : {
4375 : 1387 : stmtblock_t cond_block;
4376 : 1387 : tree size
4377 : 1387 : = gfc_create_var (gfc_array_index_type, NULL);
4378 : 1387 : tree tem, then_b, else_b, zero, cond;
4379 : :
4380 : 1387 : gfc_init_block (&cond_block);
4381 : 1387 : tem
4382 : 2774 : = gfc_full_array_size (&cond_block, decl,
4383 : 1387 : GFC_TYPE_ARRAY_RANK (type));
4384 : 1387 : tree elemsz;
4385 : 1387 : if (n->sym->ts.type == BT_CHARACTER
4386 : 52 : && n->sym->ts.deferred)
4387 : : {
4388 : 44 : tree len = n->sym->ts.u.cl->backend_decl;
4389 : 44 : len = fold_convert (size_type_node, len);
4390 : 44 : elemsz = gfc_get_char_type (n->sym->ts.kind);
4391 : 44 : elemsz = TYPE_SIZE_UNIT (elemsz);
4392 : 44 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
4393 : : len, elemsz);
4394 : 44 : }
4395 : : else
4396 : 1343 : elemsz
4397 : 1343 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4398 : 1387 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4399 : 1387 : tem = fold_build2 (MULT_EXPR, gfc_array_index_type,
4400 : : tem, elemsz);
4401 : 1387 : gfc_add_modify (&cond_block, size, tem);
4402 : 1387 : then_b = gfc_finish_block (&cond_block);
4403 : 1387 : gfc_init_block (&cond_block);
4404 : 1387 : zero = build_int_cst (gfc_array_index_type, 0);
4405 : 1387 : gfc_add_modify (&cond_block, size, zero);
4406 : 1387 : else_b = gfc_finish_block (&cond_block);
4407 : 1387 : tem = gfc_conv_descriptor_data_get (decl);
4408 : 1387 : tem = fold_convert (pvoid_type_node, tem);
4409 : 1387 : cond = fold_build2_loc (input_location, NE_EXPR,
4410 : : boolean_type_node,
4411 : : tem, null_pointer_node);
4412 : 1387 : if (present)
4413 : 309 : cond = fold_build2_loc (input_location,
4414 : : TRUTH_ANDIF_EXPR,
4415 : : boolean_type_node,
4416 : : present, cond);
4417 : 1387 : gfc_add_expr_to_block (block,
4418 : : build3_loc (input_location,
4419 : : COND_EXPR,
4420 : : void_type_node,
4421 : : cond, then_b,
4422 : : else_b));
4423 : 1387 : OMP_CLAUSE_SIZE (node) = size;
4424 : 1387 : }
4425 : 0 : else if (n->sym->attr.dimension)
4426 : : {
4427 : 0 : stmtblock_t cond_block;
4428 : 0 : gfc_init_block (&cond_block);
4429 : 0 : tree size = gfc_full_array_size (&cond_block, decl,
4430 : 0 : GFC_TYPE_ARRAY_RANK (type));
4431 : 0 : tree elemsz
4432 : 0 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4433 : 0 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4434 : 0 : size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4435 : : size, elemsz);
4436 : 0 : size = gfc_evaluate_now (size, &cond_block);
4437 : 0 : if (present)
4438 : : {
4439 : 0 : tree var = gfc_create_var (gfc_array_index_type,
4440 : : NULL);
4441 : 0 : gfc_add_modify (&cond_block, var, size);
4442 : 0 : tree cond_body = gfc_finish_block (&cond_block);
4443 : 0 : tree cond = build3_loc (input_location, COND_EXPR,
4444 : : void_type_node, present,
4445 : : cond_body, NULL_TREE);
4446 : 0 : gfc_add_expr_to_block (block, cond);
4447 : 0 : OMP_CLAUSE_SIZE (node) = var;
4448 : : }
4449 : : else
4450 : : {
4451 : 0 : gfc_add_block_to_block (block, &cond_block);
4452 : 0 : OMP_CLAUSE_SIZE (node) = size;
4453 : : }
4454 : : }
4455 : : }
4456 : 8149 : else if (present
4457 : 845 : && INDIRECT_REF_P (decl)
4458 : 8892 : && INDIRECT_REF_P (TREE_OPERAND (decl, 0)))
4459 : : {
4460 : : /* A single indirectref is handled by the middle end. */
4461 : 228 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
4462 : 228 : tree tmp = TREE_OPERAND (decl, 0);
4463 : 228 : tmp = gfc_build_cond_assign_expr (block, present, tmp,
4464 : : null_pointer_node);
4465 : 228 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp);
4466 : : }
4467 : : else
4468 : 7921 : OMP_CLAUSE_DECL (node) = decl;
4469 : :
4470 : 9536 : if (!n->sym->attr.dimension
4471 : 6056 : && n->sym->ts.type == BT_CHARACTER
4472 : 144 : && n->sym->ts.deferred)
4473 : : {
4474 : 48 : if (!DECL_P (decl))
4475 : : {
4476 : 48 : gcc_assert (TREE_CODE (decl) == INDIRECT_REF);
4477 : 48 : decl = TREE_OPERAND (decl, 0);
4478 : : }
4479 : 48 : tree cond = fold_build2_loc (input_location, NE_EXPR,
4480 : : boolean_type_node,
4481 : : decl, null_pointer_node);
4482 : 48 : if (present)
4483 : 2 : cond = fold_build2_loc (input_location,
4484 : : TRUTH_ANDIF_EXPR,
4485 : : boolean_type_node,
4486 : : present, cond);
4487 : 48 : tree len = n->sym->ts.u.cl->backend_decl;
4488 : 48 : len = fold_convert (size_type_node, len);
4489 : 48 : tree size = gfc_get_char_type (n->sym->ts.kind);
4490 : 48 : size = TYPE_SIZE_UNIT (size);
4491 : 48 : size = fold_build2 (MULT_EXPR, size_type_node, len, size);
4492 : 48 : size = build3_loc (input_location,
4493 : : COND_EXPR,
4494 : : size_type_node,
4495 : : cond, size,
4496 : : size_zero_node);
4497 : 48 : size = gfc_evaluate_now (size, block);
4498 : 48 : OMP_CLAUSE_SIZE (node) = size;
4499 : : }
4500 : 9536 : if ((TREE_CODE (decl) != PARM_DECL
4501 : 186 : || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node)))
4502 : 9350 : && n->sym->ts.type == BT_DERIVED
4503 : 10089 : && n->sym->ts.u.derived->attr.alloc_comp)
4504 : : {
4505 : : /* Save array descriptor for use in
4506 : : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4507 : : to ensure that it is not gimplified + is a decl. */
4508 : 233 : tree tmp = OMP_CLAUSE_SIZE (node);
4509 : 233 : if (tmp == NULL_TREE)
4510 : 271 : tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
4511 : 67 : : TYPE_SIZE_UNIT (TREE_TYPE (decl));
4512 : 233 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4513 : 233 : gfc_add_modify_loc (input_location, block, var, tmp);
4514 : 233 : OMP_CLAUSE_SIZE (node) = var;
4515 : 233 : gfc_allocate_lang_decl (var);
4516 : 233 : if (TREE_CODE (decl) == INDIRECT_REF)
4517 : 69 : decl = TREE_OPERAND (decl, 0);
4518 : 233 : if (TREE_CODE (decl) == INDIRECT_REF)
4519 : 2 : decl = TREE_OPERAND (decl, 0);
4520 : 233 : if (DECL_LANG_SPECIFIC (decl)
4521 : 233 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
4522 : 6 : GFC_DECL_SAVED_DESCRIPTOR (var)
4523 : 2 : = GFC_DECL_SAVED_DESCRIPTOR (decl);
4524 : : else
4525 : 231 : GFC_DECL_SAVED_DESCRIPTOR (var) = decl;
4526 : : }
4527 : : }
4528 : 5360 : else if (n->expr
4529 : 5360 : && n->expr->expr_type == EXPR_VARIABLE
4530 : 5360 : && n->expr->ref->type == REF_ARRAY
4531 : 3549 : && !n->expr->ref->next)
4532 : : {
4533 : : /* An array element or array section which is not part of a
4534 : : derived type, etc. */
4535 : 3294 : bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
4536 : 3294 : tree type = TREE_TYPE (decl);
4537 : 3294 : gomp_map_kind k = GOMP_MAP_POINTER;
4538 : 3294 : if (!openacc
4539 : 443 : && !GFC_DESCRIPTOR_TYPE_P (type)
4540 : 3682 : && !(POINTER_TYPE_P (type)
4541 : 256 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
4542 : : k = GOMP_MAP_FIRSTPRIVATE_POINTER;
4543 : 3294 : gfc_trans_omp_array_section (block, op, n, decl, element,
4544 : 3294 : !openacc, k, node, node2,
4545 : : node3, node4);
4546 : 3294 : }
4547 : 2066 : else if (n->expr
4548 : 2066 : && n->expr->expr_type == EXPR_VARIABLE
4549 : 2066 : && (n->expr->ref->type == REF_COMPONENT
4550 : : || n->expr->ref->type == REF_ARRAY)
4551 : 2066 : && lastref
4552 : 2066 : && lastref->type == REF_COMPONENT
4553 : 457 : && lastref->u.c.component->ts.type != BT_CLASS
4554 : 433 : && lastref->u.c.component->ts.type != BT_DERIVED
4555 : 341 : && !lastref->u.c.component->attr.dimension)
4556 : : {
4557 : : /* Derived type access with last component being a scalar. */
4558 : 341 : gfc_init_se (&se, NULL);
4559 : :
4560 : 341 : gfc_conv_expr (&se, n->expr);
4561 : 341 : gfc_add_block_to_block (block, &se.pre);
4562 : : /* For BT_CHARACTER a pointer is returned. */
4563 : 341 : OMP_CLAUSE_DECL (node)
4564 : 588 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
4565 : 341 : ? build_fold_indirect_ref (se.expr) : se.expr;
4566 : 341 : gfc_add_block_to_block (block, &se.post);
4567 : 341 : if (pointer || allocatable)
4568 : : {
4569 : : /* If it's a bare attach/detach clause, we just want
4570 : : to perform a single attach/detach operation, of the
4571 : : pointer itself, not of the pointed-to object. */
4572 : 161 : if (openacc
4573 : 68 : && (n->u.map.op == OMP_MAP_ATTACH
4574 : 50 : || n->u.map.op == OMP_MAP_DETACH))
4575 : : {
4576 : 36 : OMP_CLAUSE_DECL (node)
4577 : 36 : = build_fold_addr_expr (OMP_CLAUSE_DECL (node));
4578 : 36 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4579 : 36 : goto finalize_map_clause;
4580 : : }
4581 : :
4582 : 125 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4583 : 125 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
4584 : 125 : OMP_CLAUSE_DECL (node2)
4585 : 180 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
4586 : 125 : ? se.expr
4587 : 55 : : gfc_build_addr_expr (NULL, se.expr);
4588 : 125 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4589 : 125 : if (!openacc
4590 : 93 : && n->expr->ts.type == BT_CHARACTER
4591 : 54 : && n->expr->ts.deferred)
4592 : : {
4593 : 54 : gcc_assert (se.string_length);
4594 : 54 : tree tmp
4595 : 54 : = gfc_get_char_type (n->expr->ts.kind);
4596 : 54 : OMP_CLAUSE_SIZE (node)
4597 : 54 : = fold_build2 (MULT_EXPR, size_type_node,
4598 : : fold_convert (size_type_node,
4599 : : se.string_length),
4600 : : TYPE_SIZE_UNIT (tmp));
4601 : 54 : gomp_map_kind kind;
4602 : 54 : if (n->u.map.op == OMP_MAP_DELETE)
4603 : : kind = GOMP_MAP_DELETE;
4604 : 54 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4605 : : kind = GOMP_MAP_RELEASE;
4606 : : else
4607 : 48 : kind = GOMP_MAP_TO;
4608 : 54 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4609 : 54 : OMP_CLAUSE_SET_MAP_KIND (node3, kind);
4610 : 54 : OMP_CLAUSE_DECL (node3) = se.string_length;
4611 : 54 : OMP_CLAUSE_SIZE (node3)
4612 : 108 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4613 : : }
4614 : 93 : if (!openacc
4615 : 93 : && n->expr->ts.type == BT_DERIVED
4616 : 0 : && n->expr->ts.u.derived->attr.alloc_comp)
4617 : : {
4618 : : /* Save array descriptor for use in
4619 : : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4620 : : to ensure that it is not gimplified + is a decl. */
4621 : 0 : tree tmp = OMP_CLAUSE_SIZE (node);
4622 : 0 : if (tmp == NULL_TREE)
4623 : 0 : tmp = (DECL_P (se.expr)
4624 : 0 : ? DECL_SIZE_UNIT (se.expr)
4625 : 0 : : TYPE_SIZE_UNIT (TREE_TYPE (se.expr)));
4626 : 0 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4627 : 0 : gfc_add_modify_loc (input_location, block, var, tmp);
4628 : 0 : OMP_CLAUSE_SIZE (node) = var;
4629 : 0 : gfc_allocate_lang_decl (var);
4630 : 0 : if (TREE_CODE (se.expr) == INDIRECT_REF)
4631 : 0 : se.expr = TREE_OPERAND (se.expr, 0);
4632 : 0 : if (DECL_LANG_SPECIFIC (se.expr)
4633 : 0 : && GFC_DECL_SAVED_DESCRIPTOR (se.expr))
4634 : 0 : GFC_DECL_SAVED_DESCRIPTOR (var)
4635 : 0 : = GFC_DECL_SAVED_DESCRIPTOR (se.expr);
4636 : : else
4637 : 0 : GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
4638 : : }
4639 : : }
4640 : : }
4641 : 1725 : else if (n->expr
4642 : 1725 : && n->expr->expr_type == EXPR_VARIABLE
4643 : 1725 : && (n->expr->ref->type == REF_COMPONENT
4644 : : || n->expr->ref->type == REF_ARRAY))
4645 : : {
4646 : 1725 : gfc_init_se (&se, NULL);
4647 : 1725 : se.expr = gfc_maybe_dereference_var (n->sym, decl);
4648 : :
4649 : 5787 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4650 : : {
4651 : 4062 : if (ref->type == REF_COMPONENT)
4652 : : {
4653 : 2030 : if (ref->u.c.sym->attr.extension)
4654 : 91 : conv_parent_component_references (&se, ref);
4655 : :
4656 : 2030 : gfc_conv_component_ref (&se, ref);
4657 : : }
4658 : 2032 : else if (ref->type == REF_ARRAY)
4659 : : {
4660 : 2032 : if (ref->u.ar.type == AR_ELEMENT && ref->next)
4661 : 423 : gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
4662 : 423 : &n->expr->where);
4663 : : else
4664 : 1609 : gcc_assert (!ref->next);
4665 : : }
4666 : : else
4667 : 0 : sorry_at (gfc_get_location (&n->where),
4668 : : "unhandled expression type");
4669 : : }
4670 : :
4671 : 1725 : tree inner = se.expr;
4672 : :
4673 : : /* Last component is a derived type or class pointer. */
4674 : 1725 : if (lastref->type == REF_COMPONENT
4675 : 116 : && (lastref->u.c.component->ts.type == BT_DERIVED
4676 : 24 : || lastref->u.c.component->ts.type == BT_CLASS))
4677 : : {
4678 : 116 : if (pointer || allocatable)
4679 : : {
4680 : : /* If it's a bare attach/detach clause, we just want
4681 : : to perform a single attach/detach operation, of the
4682 : : pointer itself, not of the pointed-to object. */
4683 : 67 : if (openacc
4684 : 49 : && (n->u.map.op == OMP_MAP_ATTACH
4685 : 43 : || n->u.map.op == OMP_MAP_DETACH))
4686 : : {
4687 : 12 : OMP_CLAUSE_DECL (node)
4688 : 12 : = build_fold_addr_expr (inner);
4689 : 12 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4690 : 18 : goto finalize_map_clause;
4691 : : }
4692 : :
4693 : 18 : gfc_omp_namelist *n2
4694 : : = openacc ? NULL : clauses->lists[OMP_LIST_MAP];
4695 : :
4696 : 55 : bool sym_based;
4697 : 55 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n,
4698 : : n2, &sym_based);
4699 : :
4700 : : /* If the last reference is a pointer to a derived
4701 : : type ("foo%dt_ptr"), check if any subcomponents
4702 : : of the same derived type member are being mapped
4703 : : elsewhere in the clause list ("foo%dt_ptr%x",
4704 : : etc.). If we have such subcomponent mappings,
4705 : : we only create an ALLOC node for the pointer
4706 : : itself, and inhibit mapping the whole derived
4707 : : type. */
4708 : :
4709 : 103 : for (; n2 != NULL; n2 = n2->next)
4710 : : {
4711 : 54 : if ((!sym_based && n == n2)
4712 : 54 : || (sym_based && n == n2->u2.duplicate_of)
4713 : 42 : || !n2->expr)
4714 : 12 : continue;
4715 : :
4716 : 42 : if (!gfc_omp_expr_prefix_same (n->expr,
4717 : : n2->expr))
4718 : 36 : continue;
4719 : :
4720 : 6 : gfc_ref *ref1 = n->expr->ref;
4721 : 6 : gfc_ref *ref2 = n2->expr->ref;
4722 : :
4723 : 6 : while (ref1->next && ref2->next)
4724 : : {
4725 : : ref1 = ref1->next;
4726 : : ref2 = ref2->next;
4727 : : }
4728 : :
4729 : 6 : if (ref2->next)
4730 : : {
4731 : 6 : inner = build_fold_addr_expr (inner);
4732 : 6 : OMP_CLAUSE_SET_MAP_KIND (node,
4733 : : GOMP_MAP_ALLOC);
4734 : 6 : OMP_CLAUSE_DECL (node) = inner;
4735 : 6 : OMP_CLAUSE_SIZE (node)
4736 : 6 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
4737 : 6 : goto finalize_map_clause;
4738 : : }
4739 : : }
4740 : :
4741 : 49 : tree data, size;
4742 : :
4743 : 49 : if (lastref->u.c.component->ts.type == BT_CLASS)
4744 : : {
4745 : 24 : data = gfc_class_data_get (inner);
4746 : 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
4747 : 24 : data = build_fold_indirect_ref (data);
4748 : 24 : size = gfc_class_vtab_size_get (inner);
4749 : : }
4750 : : else /* BT_DERIVED. */
4751 : : {
4752 : 25 : data = inner;
4753 : 25 : size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
4754 : : }
4755 : :
4756 : 49 : OMP_CLAUSE_DECL (node) = data;
4757 : 49 : OMP_CLAUSE_SIZE (node) = size;
4758 : 49 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4759 : 49 : OMP_CLAUSE_SET_MAP_KIND (node2,
4760 : : GOMP_MAP_ATTACH_DETACH);
4761 : 49 : OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
4762 : 49 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4763 : : }
4764 : : else
4765 : : {
4766 : 49 : OMP_CLAUSE_DECL (node) = inner;
4767 : 49 : OMP_CLAUSE_SIZE (node)
4768 : 98 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
4769 : : }
4770 : 98 : if (!openacc
4771 : 14 : && n->expr->ts.type == BT_DERIVED
4772 : 14 : && n->expr->ts.u.derived->attr.alloc_comp)
4773 : : {
4774 : : /* Save array descriptor for use in
4775 : : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4776 : : to ensure that it is not gimplified + is a decl. */
4777 : 8 : tree tmp = OMP_CLAUSE_SIZE (node);
4778 : 8 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4779 : 8 : gfc_add_modify_loc (input_location, block, var, tmp);
4780 : 8 : OMP_CLAUSE_SIZE (node) = var;
4781 : 8 : gfc_allocate_lang_decl (var);
4782 : 8 : if (TREE_CODE (inner) == INDIRECT_REF)
4783 : 6 : inner = TREE_OPERAND (inner, 0);
4784 : 8 : GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
4785 : : }
4786 : : }
4787 : 1609 : else if (lastref->type == REF_ARRAY
4788 : 1609 : && lastref->u.ar.type == AR_FULL)
4789 : : {
4790 : : /* Bare attach and detach clauses don't want any
4791 : : additional nodes. */
4792 : 921 : if ((n->u.map.op == OMP_MAP_ATTACH
4793 : 890 : || n->u.map.op == OMP_MAP_DETACH)
4794 : 935 : && (POINTER_TYPE_P (TREE_TYPE (inner))
4795 : 45 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))))
4796 : : {
4797 : 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
4798 : : {
4799 : 45 : tree ptr = gfc_conv_descriptor_data_get (inner);
4800 : 45 : OMP_CLAUSE_DECL (node) = ptr;
4801 : : }
4802 : : else
4803 : 0 : OMP_CLAUSE_DECL (node) = inner;
4804 : 45 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4805 : 45 : goto finalize_map_clause;
4806 : : }
4807 : :
4808 : 876 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
4809 : : {
4810 : 706 : gomp_map_kind map_kind;
4811 : 706 : tree type = TREE_TYPE (inner);
4812 : 706 : tree ptr = gfc_conv_descriptor_data_get (inner);
4813 : 706 : ptr = build_fold_indirect_ref (ptr);
4814 : 706 : OMP_CLAUSE_DECL (node) = ptr;
4815 : 706 : int rank = GFC_TYPE_ARRAY_RANK (type);
4816 : 706 : OMP_CLAUSE_SIZE (node)
4817 : 706 : = gfc_full_array_size (block, inner, rank);
4818 : 706 : tree elemsz
4819 : 706 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4820 : 706 : map_kind = OMP_CLAUSE_MAP_KIND (node);
4821 : 706 : if (GOMP_MAP_COPY_TO_P (map_kind)
4822 : 140 : || map_kind == GOMP_MAP_ALLOC)
4823 : 593 : map_kind = ((GOMP_MAP_ALWAYS_P (map_kind)
4824 : 1090 : || gfc_expr_attr (n->expr).pointer)
4825 : 593 : ? GOMP_MAP_ALWAYS_TO : GOMP_MAP_TO);
4826 : 113 : else if (n->u.map.op == OMP_MAP_RELEASE
4827 : 109 : || n->u.map.op == OMP_MAP_DELETE)
4828 : : ;
4829 : 108 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
4830 : 108 : || op == EXEC_OACC_EXIT_DATA)
4831 : : map_kind = GOMP_MAP_RELEASE;
4832 : : else
4833 : 29 : map_kind = GOMP_MAP_ALLOC;
4834 : 706 : if (!openacc
4835 : 566 : && n->expr->ts.type == BT_CHARACTER
4836 : 42 : && n->expr->ts.deferred)
4837 : : {
4838 : 42 : gcc_assert (se.string_length);
4839 : 42 : tree len = fold_convert (size_type_node,
4840 : : se.string_length);
4841 : 42 : elemsz = gfc_get_char_type (n->expr->ts.kind);
4842 : 42 : elemsz = TYPE_SIZE_UNIT (elemsz);
4843 : 42 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
4844 : : len, elemsz);
4845 : 42 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4846 : 42 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
4847 : 42 : OMP_CLAUSE_DECL (node4) = se.string_length;
4848 : 42 : OMP_CLAUSE_SIZE (node4)
4849 : 84 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4850 : : }
4851 : 706 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4852 : 706 : OMP_CLAUSE_SIZE (node)
4853 : 706 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
4854 : : OMP_CLAUSE_SIZE (node), elemsz);
4855 : 706 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4856 : 706 : if (map_kind == GOMP_MAP_RELEASE
4857 : 706 : || map_kind == GOMP_MAP_DELETE)
4858 : : {
4859 : 84 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
4860 : 84 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
4861 : : }
4862 : : else
4863 : 622 : OMP_CLAUSE_SET_MAP_KIND (node2,
4864 : : GOMP_MAP_TO_PSET);
4865 : 706 : OMP_CLAUSE_DECL (node2) = inner;
4866 : 706 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
4867 : 706 : if (!openacc)
4868 : : {
4869 : 566 : if (n->expr->ts.type == BT_DERIVED
4870 : 12 : && n->expr->ts.u.derived->attr.alloc_comp)
4871 : : {
4872 : : /* Save array descriptor for use
4873 : : in gfc_omp_deep_mapping{,_p,_cnt}; force
4874 : : evaluate to ensure that it is
4875 : : not gimplified + is a decl. */
4876 : 6 : tree tmp = OMP_CLAUSE_SIZE (node);
4877 : 6 : tree var = gfc_create_var (TREE_TYPE (tmp),
4878 : : NULL);
4879 : 6 : gfc_add_modify_loc (map_loc, block,
4880 : : var, tmp);
4881 : 6 : OMP_CLAUSE_SIZE (node) = var;
4882 : 6 : gfc_allocate_lang_decl (var);
4883 : 6 : GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
4884 : : }
4885 : :
4886 : 566 : gfc_omp_namelist *n2
4887 : : = clauses->lists[OMP_LIST_MAP];
4888 : :
4889 : : /* If we don't have a mapping of a smaller part
4890 : : of the array -- or we can't prove that we do
4891 : : statically -- set this flag. If there is a
4892 : : mapping of a smaller part of the array after
4893 : : all, this will turn into a no-op at
4894 : : runtime. */
4895 : 566 : OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (node) = 1;
4896 : :
4897 : 566 : bool sym_based;
4898 : 566 : n2 = get_symbol_rooted_namelist (sym_rooted_nl,
4899 : : n, n2,
4900 : : &sym_based);
4901 : :
4902 : 566 : bool drop_mapping = false;
4903 : :
4904 : 1805 : for (; n2 != NULL; n2 = n2->next)
4905 : : {
4906 : 1519 : if ((!sym_based && n == n2)
4907 : 1519 : || (sym_based && n == n2->u2.duplicate_of)
4908 : 1215 : || !n2->expr)
4909 : 304 : continue;
4910 : :
4911 : 1215 : if (!gfc_omp_expr_prefix_same (n->expr,
4912 : : n2->expr))
4913 : 935 : continue;
4914 : :
4915 : 280 : gfc_ref *ref1 = n->expr->ref;
4916 : 280 : gfc_ref *ref2 = n2->expr->ref;
4917 : :
4918 : : /* We know ref1 and ref2 overlap. We're
4919 : : interested in whether ref2 describes a
4920 : : smaller part of the array than ref1, which
4921 : : we already know refers to the full
4922 : : array. */
4923 : :
4924 : 620 : while (ref1->next && ref2->next)
4925 : : {
4926 : : ref1 = ref1->next;
4927 : : ref2 = ref2->next;
4928 : : }
4929 : :
4930 : 280 : if (ref2->next
4931 : 280 : || (ref2->type == REF_ARRAY
4932 : 280 : && (ref2->u.ar.type == AR_ELEMENT
4933 : 280 : || (ref2->u.ar.type
4934 : : == AR_SECTION))))
4935 : : {
4936 : : drop_mapping = true;
4937 : : break;
4938 : : }
4939 : : }
4940 : 566 : if (drop_mapping)
4941 : 280 : continue;
4942 : : }
4943 : 426 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4944 : 426 : OMP_CLAUSE_SET_MAP_KIND (node3,
4945 : : GOMP_MAP_ATTACH_DETACH);
4946 : 426 : OMP_CLAUSE_DECL (node3)
4947 : 426 : = gfc_conv_descriptor_data_get (inner);
4948 : : /* Similar to gfc_trans_omp_array_section (details
4949 : : there), we add/keep the cast for OpenMP to prevent
4950 : : that an 'alloc:' gets added for node3 ('desc.data')
4951 : : as that is part of the whole descriptor (node3).
4952 : : TODO: Remove once the ME handles this properly. */
4953 : 426 : if (!openacc)
4954 : 286 : OMP_CLAUSE_DECL (node3)
4955 : 572 : = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)),
4956 : : OMP_CLAUSE_DECL (node3));
4957 : : else
4958 : 140 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
4959 : 426 : OMP_CLAUSE_SIZE (node3) = size_int (0);
4960 : : }
4961 : : else
4962 : 170 : OMP_CLAUSE_DECL (node) = inner;
4963 : : }
4964 : 688 : else if (lastref->type == REF_ARRAY)
4965 : : {
4966 : : /* An array element or section. */
4967 : 688 : bool element = lastref->u.ar.type == AR_ELEMENT;
4968 : 688 : gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH;
4969 : 688 : gfc_trans_omp_array_section (block, op, n, inner, element,
4970 : 688 : !openacc, kind, node, node2,
4971 : : node3, node4);
4972 : : }
4973 : : else
4974 : 0 : gcc_unreachable ();
4975 : : }
4976 : : else
4977 : 0 : sorry_at (gfc_get_location (&n->where), "unhandled expression");
4978 : :
4979 : 14685 : finalize_map_clause:
4980 : :
4981 : 14685 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4982 : 14685 : if (node2)
4983 : 4765 : omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
4984 : 14685 : if (node3)
4985 : 5976 : omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
4986 : 14685 : if (node4)
4987 : 3526 : omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
4988 : 14685 : if (node5)
4989 : 4 : omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
4990 : : }
4991 : : break;
4992 : : case OMP_LIST_TO:
4993 : : case OMP_LIST_FROM:
4994 : : case OMP_LIST_CACHE:
4995 : 3637 : for (; n != NULL; n = n->next)
4996 : : {
4997 : 1862 : if (!n->sym->attr.referenced
4998 : 0 : && n->sym->attr.flavor != FL_PARAMETER)
4999 : 0 : continue;
5000 : :
5001 : 1862 : switch (list)
5002 : : {
5003 : : case OMP_LIST_TO:
5004 : : clause_code = OMP_CLAUSE_TO;
5005 : : break;
5006 : 1030 : case OMP_LIST_FROM:
5007 : 1030 : clause_code = OMP_CLAUSE_FROM;
5008 : 1030 : break;
5009 : 84 : case OMP_LIST_CACHE:
5010 : 84 : clause_code = OMP_CLAUSE__CACHE_;
5011 : 84 : break;
5012 : 0 : default:
5013 : 0 : gcc_unreachable ();
5014 : : }
5015 : 1862 : tree node = build_omp_clause (gfc_get_location (&n->where),
5016 : : clause_code);
5017 : 1862 : if (n->expr == NULL
5018 : 128 : || (n->expr->ref->type == REF_ARRAY
5019 : 116 : && n->expr->ref->u.ar.type == AR_FULL
5020 : 0 : && n->expr->ref->next == NULL))
5021 : : {
5022 : 1734 : tree decl = gfc_trans_omp_variable (n->sym, false);
5023 : 1734 : if (gfc_omp_privatize_by_reference (decl))
5024 : : {
5025 : 1047 : if (gfc_omp_is_allocatable_or_ptr (decl))
5026 : 240 : decl = build_fold_indirect_ref (decl);
5027 : 1047 : decl = build_fold_indirect_ref (decl);
5028 : : }
5029 : 687 : else if (DECL_P (decl))
5030 : 687 : TREE_ADDRESSABLE (decl) = 1;
5031 : 1734 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5032 : : {
5033 : 597 : tree type = TREE_TYPE (decl);
5034 : 597 : tree ptr = gfc_conv_descriptor_data_get (decl);
5035 : 597 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5036 : 597 : ptr = build_fold_indirect_ref (ptr);
5037 : 597 : OMP_CLAUSE_DECL (node) = ptr;
5038 : 597 : OMP_CLAUSE_SIZE (node)
5039 : 597 : = gfc_full_array_size (block, decl,
5040 : 597 : GFC_TYPE_ARRAY_RANK (type));
5041 : 597 : tree elemsz
5042 : 597 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5043 : 597 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5044 : 1194 : OMP_CLAUSE_SIZE (node)
5045 : 1194 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5046 : : OMP_CLAUSE_SIZE (node), elemsz);
5047 : : }
5048 : : else
5049 : : {
5050 : 1137 : OMP_CLAUSE_DECL (node) = decl;
5051 : 1137 : if (gfc_omp_is_allocatable_or_ptr (decl))
5052 : 120 : OMP_CLAUSE_SIZE (node)
5053 : 240 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
5054 : : }
5055 : : }
5056 : : else
5057 : : {
5058 : 128 : tree ptr;
5059 : 128 : gfc_init_se (&se, NULL);
5060 : 128 : if (n->expr->rank == 0)
5061 : : {
5062 : 5 : gfc_conv_expr_reference (&se, n->expr);
5063 : 5 : ptr = se.expr;
5064 : 5 : gfc_add_block_to_block (block, &se.pre);
5065 : 5 : OMP_CLAUSE_SIZE (node)
5066 : 10 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
5067 : : }
5068 : : else
5069 : : {
5070 : 123 : gfc_conv_expr_descriptor (&se, n->expr);
5071 : 123 : ptr = gfc_conv_array_data (se.expr);
5072 : 123 : tree type = TREE_TYPE (se.expr);
5073 : 123 : gfc_add_block_to_block (block, &se.pre);
5074 : 123 : OMP_CLAUSE_SIZE (node)
5075 : 123 : = gfc_full_array_size (block, se.expr,
5076 : 123 : GFC_TYPE_ARRAY_RANK (type));
5077 : 123 : tree elemsz
5078 : 123 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5079 : 123 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5080 : 246 : OMP_CLAUSE_SIZE (node)
5081 : 246 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5082 : : OMP_CLAUSE_SIZE (node), elemsz);
5083 : : }
5084 : 128 : gfc_add_block_to_block (block, &se.post);
5085 : 128 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5086 : 128 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
5087 : : }
5088 : 1862 : if (n->u.present_modifier)
5089 : 5 : OMP_CLAUSE_MOTION_PRESENT (node) = 1;
5090 : 1862 : if (list == OMP_LIST_CACHE && n->u.map.readonly)
5091 : 16 : OMP_CLAUSE__CACHE__READONLY (node) = 1;
5092 : 1862 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5093 : : }
5094 : : break;
5095 : : case OMP_LIST_USES_ALLOCATORS:
5096 : : /* Ignore pre-defined allocators as no special treatment is needed. */
5097 : 30 : for (; n != NULL; n = n->next)
5098 : 28 : if (n->sym->attr.flavor == FL_VARIABLE)
5099 : : break;
5100 : 12 : if (n != NULL)
5101 : 10 : sorry_at (input_location, "%<uses_allocators%> clause with traits "
5102 : : "and memory spaces");
5103 : : break;
5104 : : default:
5105 : : break;
5106 : : }
5107 : : }
5108 : :
5109 : : /* Free hashmap if we built it. */
5110 : 31514 : if (sym_rooted_nl)
5111 : : {
5112 : 276 : typedef hash_map<gfc_symbol *, gfc_omp_namelist *>::iterator hti;
5113 : 942 : for (hti it = sym_rooted_nl->begin (); it != sym_rooted_nl->end (); ++it)
5114 : : {
5115 : 333 : gfc_omp_namelist *&nl = (*it).second;
5116 : 1340 : while (nl)
5117 : : {
5118 : 1007 : gfc_omp_namelist *next = nl->next;
5119 : 1007 : free (nl);
5120 : 1007 : nl = next;
5121 : : }
5122 : : }
5123 : 276 : delete sym_rooted_nl;
5124 : : }
5125 : :
5126 : 31514 : if (clauses->if_expr)
5127 : : {
5128 : 1109 : tree if_var;
5129 : :
5130 : 1109 : gfc_init_se (&se, NULL);
5131 : 1109 : gfc_conv_expr (&se, clauses->if_expr);
5132 : 1109 : gfc_add_block_to_block (block, &se.pre);
5133 : 1109 : if_var = gfc_evaluate_now (se.expr, block);
5134 : 1109 : gfc_add_block_to_block (block, &se.post);
5135 : :
5136 : 1109 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5137 : 1109 : OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
5138 : 1109 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5139 : 1109 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5140 : : }
5141 : :
5142 : 346654 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
5143 : 315140 : if (clauses->if_exprs[ifc])
5144 : : {
5145 : 123 : tree if_var;
5146 : :
5147 : 123 : gfc_init_se (&se, NULL);
5148 : 123 : gfc_conv_expr (&se, clauses->if_exprs[ifc]);
5149 : 123 : gfc_add_block_to_block (block, &se.pre);
5150 : 123 : if_var = gfc_evaluate_now (se.expr, block);
5151 : 123 : gfc_add_block_to_block (block, &se.post);
5152 : :
5153 : 123 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5154 : 123 : switch (ifc)
5155 : : {
5156 : 0 : case OMP_IF_CANCEL:
5157 : 0 : OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
5158 : 0 : break;
5159 : 40 : case OMP_IF_PARALLEL:
5160 : 40 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
5161 : 40 : break;
5162 : 39 : case OMP_IF_SIMD:
5163 : 39 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
5164 : 39 : break;
5165 : 1 : case OMP_IF_TASK:
5166 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
5167 : 1 : break;
5168 : 23 : case OMP_IF_TASKLOOP:
5169 : 23 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
5170 : 23 : break;
5171 : 16 : case OMP_IF_TARGET:
5172 : 16 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
5173 : 16 : break;
5174 : 1 : case OMP_IF_TARGET_DATA:
5175 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
5176 : 1 : break;
5177 : 1 : case OMP_IF_TARGET_UPDATE:
5178 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
5179 : 1 : break;
5180 : 1 : case OMP_IF_TARGET_ENTER_DATA:
5181 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
5182 : 1 : break;
5183 : 1 : case OMP_IF_TARGET_EXIT_DATA:
5184 : 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
5185 : 1 : break;
5186 : : default:
5187 : : gcc_unreachable ();
5188 : : }
5189 : 123 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5190 : 123 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5191 : : }
5192 : :
5193 : 31514 : if (clauses->self_expr)
5194 : : {
5195 : 159 : tree self_var;
5196 : :
5197 : 159 : gfc_init_se (&se, NULL);
5198 : 159 : gfc_conv_expr (&se, clauses->self_expr);
5199 : 159 : gfc_add_block_to_block (block, &se.pre);
5200 : 159 : self_var = gfc_evaluate_now (se.expr, block);
5201 : 159 : gfc_add_block_to_block (block, &se.post);
5202 : :
5203 : 159 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF);
5204 : 159 : OMP_CLAUSE_SELF_EXPR (c) = self_var;
5205 : 159 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5206 : : }
5207 : :
5208 : 31514 : if (clauses->final_expr)
5209 : : {
5210 : 64 : tree final_var;
5211 : :
5212 : 64 : gfc_init_se (&se, NULL);
5213 : 64 : gfc_conv_expr (&se, clauses->final_expr);
5214 : 64 : gfc_add_block_to_block (block, &se.pre);
5215 : 64 : final_var = gfc_evaluate_now (se.expr, block);
5216 : 64 : gfc_add_block_to_block (block, &se.post);
5217 : :
5218 : 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
5219 : 64 : OMP_CLAUSE_FINAL_EXPR (c) = final_var;
5220 : 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5221 : : }
5222 : :
5223 : 31514 : if (clauses->novariants)
5224 : : {
5225 : 8 : tree novariants_var;
5226 : :
5227 : 8 : gfc_init_se (&se, NULL);
5228 : 8 : gfc_conv_expr (&se, clauses->novariants);
5229 : 8 : gfc_add_block_to_block (block, &se.pre);
5230 : 8 : novariants_var = gfc_evaluate_now (se.expr, block);
5231 : 8 : gfc_add_block_to_block (block, &se.post);
5232 : :
5233 : 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
5234 : 8 : OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
5235 : 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5236 : : }
5237 : :
5238 : 31514 : if (clauses->nocontext)
5239 : : {
5240 : 9 : tree nocontext_var;
5241 : :
5242 : 9 : gfc_init_se (&se, NULL);
5243 : 9 : gfc_conv_expr (&se, clauses->nocontext);
5244 : 9 : gfc_add_block_to_block (block, &se.pre);
5245 : 9 : nocontext_var = gfc_evaluate_now (se.expr, block);
5246 : 9 : gfc_add_block_to_block (block, &se.post);
5247 : :
5248 : 9 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
5249 : 9 : OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
5250 : 9 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5251 : : }
5252 : :
5253 : 31514 : if (clauses->num_threads)
5254 : : {
5255 : 943 : tree num_threads;
5256 : :
5257 : 943 : gfc_init_se (&se, NULL);
5258 : 943 : gfc_conv_expr (&se, clauses->num_threads);
5259 : 943 : gfc_add_block_to_block (block, &se.pre);
5260 : 943 : num_threads = gfc_evaluate_now (se.expr, block);
5261 : 943 : gfc_add_block_to_block (block, &se.post);
5262 : :
5263 : 943 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS);
5264 : 943 : OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
5265 : 943 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5266 : : }
5267 : :
5268 : 31514 : if (clauses->dyn_groupprivate)
5269 : : {
5270 : 5 : gfc_init_se (&se, NULL);
5271 : 5 : gfc_conv_expr (&se, clauses->dyn_groupprivate);
5272 : 5 : gfc_add_block_to_block (block, &se.pre);
5273 : 5 : tree expr = (CONSTANT_CLASS_P (se.expr) || DECL_P (se.expr)
5274 : 5 : ? se.expr : gfc_evaluate_now (se.expr, block));
5275 : 5 : gfc_add_block_to_block (block, &se.post);
5276 : :
5277 : 5 : enum omp_clause_fallback_kind kind = OMP_CLAUSE_FALLBACK_UNSPECIFIED;
5278 : 5 : switch (clauses->fallback)
5279 : : {
5280 : : case OMP_FALLBACK_ABORT:
5281 : : kind = OMP_CLAUSE_FALLBACK_ABORT;
5282 : : break;
5283 : : case OMP_FALLBACK_DEFAULT_MEM:
5284 : : kind = OMP_CLAUSE_FALLBACK_DEFAULT_MEM;
5285 : : break;
5286 : : case OMP_FALLBACK_NULL:
5287 : : kind = OMP_CLAUSE_FALLBACK_NULL;
5288 : : break;
5289 : : case OMP_FALLBACK_NONE:
5290 : : break;
5291 : : }
5292 : 5 : c = build_omp_clause (gfc_get_location (&where),
5293 : : OMP_CLAUSE_DYN_GROUPPRIVATE);
5294 : 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_KIND (c) = kind;
5295 : 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_EXPR (c) = expr;
5296 : 5 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5297 : : }
5298 : :
5299 : 31514 : chunk_size = NULL_TREE;
5300 : 31514 : if (clauses->chunk_size)
5301 : : {
5302 : 493 : gfc_init_se (&se, NULL);
5303 : 493 : gfc_conv_expr (&se, clauses->chunk_size);
5304 : 493 : gfc_add_block_to_block (block, &se.pre);
5305 : 493 : chunk_size = gfc_evaluate_now (se.expr, block);
5306 : 493 : gfc_add_block_to_block (block, &se.post);
5307 : : }
5308 : :
5309 : 31514 : if (clauses->sched_kind != OMP_SCHED_NONE)
5310 : : {
5311 : 782 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
5312 : 782 : OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
5313 : 782 : switch (clauses->sched_kind)
5314 : : {
5315 : 407 : case OMP_SCHED_STATIC:
5316 : 407 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
5317 : 407 : break;
5318 : 159 : case OMP_SCHED_DYNAMIC:
5319 : 159 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
5320 : 159 : break;
5321 : 125 : case OMP_SCHED_GUIDED:
5322 : 125 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
5323 : 125 : break;
5324 : 84 : case OMP_SCHED_RUNTIME:
5325 : 84 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
5326 : 84 : break;
5327 : 7 : case OMP_SCHED_AUTO:
5328 : 7 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
5329 : 7 : break;
5330 : 0 : default:
5331 : 0 : gcc_unreachable ();
5332 : : }
5333 : 782 : if (clauses->sched_monotonic)
5334 : 54 : OMP_CLAUSE_SCHEDULE_KIND (c)
5335 : 27 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5336 : : | OMP_CLAUSE_SCHEDULE_MONOTONIC);
5337 : 755 : else if (clauses->sched_nonmonotonic)
5338 : 46 : OMP_CLAUSE_SCHEDULE_KIND (c)
5339 : 23 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5340 : : | OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
5341 : 782 : if (clauses->sched_simd)
5342 : 17 : OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
5343 : 782 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5344 : : }
5345 : :
5346 : 31514 : if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
5347 : : {
5348 : 1075 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
5349 : 1075 : switch (clauses->default_sharing)
5350 : : {
5351 : 665 : case OMP_DEFAULT_NONE:
5352 : 665 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
5353 : 665 : break;
5354 : 183 : case OMP_DEFAULT_SHARED:
5355 : 183 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
5356 : 183 : break;
5357 : 24 : case OMP_DEFAULT_PRIVATE:
5358 : 24 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
5359 : 24 : break;
5360 : 8 : case OMP_DEFAULT_FIRSTPRIVATE:
5361 : 8 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
5362 : 8 : break;
5363 : 195 : case OMP_DEFAULT_PRESENT:
5364 : 195 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
5365 : 195 : break;
5366 : 0 : default:
5367 : 0 : gcc_unreachable ();
5368 : : }
5369 : 1075 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5370 : : }
5371 : :
5372 : 31514 : if (clauses->nowait)
5373 : : {
5374 : 2060 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT);
5375 : 2060 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5376 : : }
5377 : :
5378 : 31514 : if (clauses->full)
5379 : : {
5380 : 47 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FULL);
5381 : 47 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5382 : : }
5383 : :
5384 : 31514 : if (clauses->partial)
5385 : : {
5386 : 259 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARTIAL);
5387 : 259 : OMP_CLAUSE_PARTIAL_EXPR (c)
5388 : 518 : = (clauses->partial > 0
5389 : 259 : ? build_int_cst (integer_type_node, clauses->partial)
5390 : : : NULL_TREE);
5391 : 259 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5392 : : }
5393 : :
5394 : 31514 : if (clauses->sizes_list)
5395 : : {
5396 : : tree list = NULL_TREE;
5397 : 344 : for (gfc_expr_list *el = clauses->sizes_list; el; el = el->next)
5398 : 224 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
5399 : : list);
5400 : :
5401 : 120 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIZES);
5402 : 120 : OMP_CLAUSE_SIZES_LIST (c) = nreverse (list);
5403 : 120 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5404 : : }
5405 : :
5406 : 31514 : if (clauses->ordered)
5407 : : {
5408 : 314 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
5409 : 314 : OMP_CLAUSE_ORDERED_EXPR (c)
5410 : 314 : = clauses->orderedc ? build_int_cst (integer_type_node,
5411 : 133 : clauses->orderedc) : NULL_TREE;
5412 : 314 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5413 : : }
5414 : :
5415 : 31514 : if (clauses->order_concurrent)
5416 : : {
5417 : 303 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
5418 : 303 : OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
5419 : 303 : OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
5420 : 303 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5421 : : }
5422 : :
5423 : 31514 : if (clauses->untied)
5424 : : {
5425 : 141 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED);
5426 : 141 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5427 : : }
5428 : :
5429 : 31514 : if (clauses->mergeable)
5430 : : {
5431 : 32 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
5432 : 32 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5433 : : }
5434 : :
5435 : 31514 : if (clauses->collapse)
5436 : : {
5437 : 1645 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE);
5438 : 1645 : OMP_CLAUSE_COLLAPSE_EXPR (c)
5439 : 1645 : = build_int_cst (integer_type_node, clauses->collapse);
5440 : 1645 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5441 : : }
5442 : :
5443 : 31514 : if (clauses->inbranch)
5444 : : {
5445 : 18 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH);
5446 : 18 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5447 : : }
5448 : :
5449 : 31514 : if (clauses->notinbranch)
5450 : : {
5451 : 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH);
5452 : 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5453 : : }
5454 : :
5455 : 31514 : switch (clauses->cancel)
5456 : : {
5457 : : case OMP_CANCEL_UNKNOWN:
5458 : : break;
5459 : 0 : case OMP_CANCEL_PARALLEL:
5460 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL);
5461 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5462 : 0 : break;
5463 : 0 : case OMP_CANCEL_SECTIONS:
5464 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS);
5465 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5466 : 0 : break;
5467 : 0 : case OMP_CANCEL_DO:
5468 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR);
5469 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5470 : 0 : break;
5471 : 0 : case OMP_CANCEL_TASKGROUP:
5472 : 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP);
5473 : 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5474 : 0 : break;
5475 : : }
5476 : :
5477 : 31514 : if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
5478 : : {
5479 : 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
5480 : 64 : switch (clauses->proc_bind)
5481 : : {
5482 : 1 : case OMP_PROC_BIND_PRIMARY:
5483 : 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
5484 : 1 : break;
5485 : 9 : case OMP_PROC_BIND_MASTER:
5486 : 9 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
5487 : 9 : break;
5488 : 53 : case OMP_PROC_BIND_SPREAD:
5489 : 53 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
5490 : 53 : break;
5491 : 1 : case OMP_PROC_BIND_CLOSE:
5492 : 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
5493 : 1 : break;
5494 : 0 : default:
5495 : 0 : gcc_unreachable ();
5496 : : }
5497 : 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5498 : : }
5499 : :
5500 : 31514 : if (clauses->safelen_expr)
5501 : : {
5502 : 89 : tree safelen_var;
5503 : :
5504 : 89 : gfc_init_se (&se, NULL);
5505 : 89 : gfc_conv_expr (&se, clauses->safelen_expr);
5506 : 89 : gfc_add_block_to_block (block, &se.pre);
5507 : 89 : safelen_var = gfc_evaluate_now (se.expr, block);
5508 : 89 : gfc_add_block_to_block (block, &se.post);
5509 : :
5510 : 89 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
5511 : 89 : OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
5512 : 89 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5513 : : }
5514 : :
5515 : 31514 : if (clauses->simdlen_expr)
5516 : : {
5517 : 110 : if (declare_simd)
5518 : : {
5519 : 65 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5520 : 65 : OMP_CLAUSE_SIMDLEN_EXPR (c)
5521 : 65 : = gfc_conv_constant_to_tree (clauses->simdlen_expr);
5522 : 65 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5523 : : }
5524 : : else
5525 : : {
5526 : 45 : tree simdlen_var;
5527 : :
5528 : 45 : gfc_init_se (&se, NULL);
5529 : 45 : gfc_conv_expr (&se, clauses->simdlen_expr);
5530 : 45 : gfc_add_block_to_block (block, &se.pre);
5531 : 45 : simdlen_var = gfc_evaluate_now (se.expr, block);
5532 : 45 : gfc_add_block_to_block (block, &se.post);
5533 : :
5534 : 45 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5535 : 45 : OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
5536 : 45 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5537 : : }
5538 : : }
5539 : :
5540 : 31514 : if (clauses->num_teams_upper)
5541 : : {
5542 : 111 : tree num_teams_lower = NULL_TREE, num_teams_upper;
5543 : :
5544 : 111 : gfc_init_se (&se, NULL);
5545 : 111 : gfc_conv_expr (&se, clauses->num_teams_upper);
5546 : 111 : gfc_add_block_to_block (block, &se.pre);
5547 : 111 : num_teams_upper = gfc_evaluate_now (se.expr, block);
5548 : 111 : gfc_add_block_to_block (block, &se.post);
5549 : :
5550 : 111 : if (clauses->num_teams_lower)
5551 : : {
5552 : 21 : gfc_init_se (&se, NULL);
5553 : 21 : gfc_conv_expr (&se, clauses->num_teams_lower);
5554 : 21 : gfc_add_block_to_block (block, &se.pre);
5555 : 21 : num_teams_lower = gfc_evaluate_now (se.expr, block);
5556 : 21 : gfc_add_block_to_block (block, &se.post);
5557 : : }
5558 : 111 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
5559 : 111 : OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
5560 : 111 : OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
5561 : 111 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5562 : : }
5563 : :
5564 : 31514 : if (clauses->device)
5565 : : {
5566 : 279 : tree device;
5567 : :
5568 : 279 : gfc_init_se (&se, NULL);
5569 : 279 : gfc_conv_expr (&se, clauses->device);
5570 : 279 : gfc_add_block_to_block (block, &se.pre);
5571 : 279 : device = gfc_evaluate_now (se.expr, block);
5572 : 279 : gfc_add_block_to_block (block, &se.post);
5573 : :
5574 : 279 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
5575 : 279 : OMP_CLAUSE_DEVICE_ID (c) = device;
5576 : :
5577 : 279 : if (clauses->ancestor)
5578 : 39 : OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
5579 : :
5580 : 279 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5581 : : }
5582 : :
5583 : 31514 : if (clauses->thread_limit)
5584 : : {
5585 : 105 : tree thread_limit;
5586 : :
5587 : 105 : gfc_init_se (&se, NULL);
5588 : 105 : gfc_conv_expr (&se, clauses->thread_limit);
5589 : 105 : gfc_add_block_to_block (block, &se.pre);
5590 : 105 : thread_limit = gfc_evaluate_now (se.expr, block);
5591 : 105 : gfc_add_block_to_block (block, &se.post);
5592 : :
5593 : 105 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT);
5594 : 105 : OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
5595 : 105 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5596 : : }
5597 : :
5598 : 31514 : chunk_size = NULL_TREE;
5599 : 31514 : if (clauses->dist_chunk_size)
5600 : : {
5601 : 81 : gfc_init_se (&se, NULL);
5602 : 81 : gfc_conv_expr (&se, clauses->dist_chunk_size);
5603 : 81 : gfc_add_block_to_block (block, &se.pre);
5604 : 81 : chunk_size = gfc_evaluate_now (se.expr, block);
5605 : 81 : gfc_add_block_to_block (block, &se.post);
5606 : : }
5607 : :
5608 : 31514 : if (clauses->dist_sched_kind != OMP_SCHED_NONE)
5609 : : {
5610 : 94 : c = build_omp_clause (gfc_get_location (&where),
5611 : : OMP_CLAUSE_DIST_SCHEDULE);
5612 : 94 : OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
5613 : 94 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5614 : : }
5615 : :
5616 : 31514 : if (clauses->grainsize)
5617 : : {
5618 : 33 : tree grainsize;
5619 : :
5620 : 33 : gfc_init_se (&se, NULL);
5621 : 33 : gfc_conv_expr (&se, clauses->grainsize);
5622 : 33 : gfc_add_block_to_block (block, &se.pre);
5623 : 33 : grainsize = gfc_evaluate_now (se.expr, block);
5624 : 33 : gfc_add_block_to_block (block, &se.post);
5625 : :
5626 : 33 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
5627 : 33 : OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
5628 : 33 : if (clauses->grainsize_strict)
5629 : 1 : OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
5630 : 33 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5631 : : }
5632 : :
5633 : 31514 : if (clauses->num_tasks)
5634 : : {
5635 : 25 : tree num_tasks;
5636 : :
5637 : 25 : gfc_init_se (&se, NULL);
5638 : 25 : gfc_conv_expr (&se, clauses->num_tasks);
5639 : 25 : gfc_add_block_to_block (block, &se.pre);
5640 : 25 : num_tasks = gfc_evaluate_now (se.expr, block);
5641 : 25 : gfc_add_block_to_block (block, &se.post);
5642 : :
5643 : 25 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
5644 : 25 : OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
5645 : 25 : if (clauses->num_tasks_strict)
5646 : 1 : OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
5647 : 25 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5648 : : }
5649 : :
5650 : 31514 : if (clauses->priority)
5651 : : {
5652 : 34 : tree priority;
5653 : :
5654 : 34 : gfc_init_se (&se, NULL);
5655 : 34 : gfc_conv_expr (&se, clauses->priority);
5656 : 34 : gfc_add_block_to_block (block, &se.pre);
5657 : 34 : priority = gfc_evaluate_now (se.expr, block);
5658 : 34 : gfc_add_block_to_block (block, &se.post);
5659 : :
5660 : 34 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY);
5661 : 34 : OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
5662 : 34 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5663 : : }
5664 : :
5665 : 31514 : if (clauses->detach)
5666 : : {
5667 : 116 : tree detach;
5668 : :
5669 : 116 : gfc_init_se (&se, NULL);
5670 : 116 : gfc_conv_expr (&se, clauses->detach);
5671 : 116 : gfc_add_block_to_block (block, &se.pre);
5672 : 116 : detach = se.expr;
5673 : 116 : gfc_add_block_to_block (block, &se.post);
5674 : :
5675 : 116 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
5676 : 116 : TREE_ADDRESSABLE (detach) = 1;
5677 : 116 : OMP_CLAUSE_DECL (c) = detach;
5678 : 116 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5679 : : }
5680 : :
5681 : 31514 : if (clauses->filter)
5682 : : {
5683 : 31 : tree filter;
5684 : :
5685 : 31 : gfc_init_se (&se, NULL);
5686 : 31 : gfc_conv_expr (&se, clauses->filter);
5687 : 31 : gfc_add_block_to_block (block, &se.pre);
5688 : 31 : filter = gfc_evaluate_now (se.expr, block);
5689 : 31 : gfc_add_block_to_block (block, &se.post);
5690 : :
5691 : 31 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
5692 : 31 : OMP_CLAUSE_FILTER_EXPR (c) = filter;
5693 : 31 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5694 : : }
5695 : :
5696 : 31514 : if (clauses->hint)
5697 : : {
5698 : 8 : tree hint;
5699 : :
5700 : 8 : gfc_init_se (&se, NULL);
5701 : 8 : gfc_conv_expr (&se, clauses->hint);
5702 : 8 : gfc_add_block_to_block (block, &se.pre);
5703 : 8 : hint = gfc_evaluate_now (se.expr, block);
5704 : 8 : gfc_add_block_to_block (block, &se.post);
5705 : :
5706 : 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT);
5707 : 8 : OMP_CLAUSE_HINT_EXPR (c) = hint;
5708 : 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5709 : : }
5710 : :
5711 : 31514 : if (clauses->simd)
5712 : : {
5713 : 22 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD);
5714 : 22 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5715 : : }
5716 : 31514 : if (clauses->threads)
5717 : : {
5718 : 11 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS);
5719 : 11 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5720 : : }
5721 : 31514 : if (clauses->nogroup)
5722 : : {
5723 : 13 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
5724 : 13 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5725 : : }
5726 : :
5727 : 220598 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
5728 : : {
5729 : 189084 : if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
5730 : 188931 : continue;
5731 : 153 : enum omp_clause_defaultmap_kind behavior, category;
5732 : 153 : switch ((gfc_omp_defaultmap_category) i)
5733 : : {
5734 : : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
5735 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
5736 : : break;
5737 : : case OMP_DEFAULTMAP_CAT_ALL:
5738 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL;
5739 : : break;
5740 : : case OMP_DEFAULTMAP_CAT_SCALAR:
5741 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
5742 : : break;
5743 : : case OMP_DEFAULTMAP_CAT_AGGREGATE:
5744 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
5745 : : break;
5746 : : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
5747 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
5748 : : break;
5749 : : case OMP_DEFAULTMAP_CAT_POINTER:
5750 : : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
5751 : : break;
5752 : : default: gcc_unreachable ();
5753 : : }
5754 : 153 : switch (clauses->defaultmap[i])
5755 : : {
5756 : : case OMP_DEFAULTMAP_ALLOC:
5757 : : behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
5758 : : break;
5759 : : case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
5760 : : case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
5761 : : case OMP_DEFAULTMAP_TOFROM:
5762 : : behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
5763 : : break;
5764 : : case OMP_DEFAULTMAP_FIRSTPRIVATE:
5765 : : behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
5766 : : break;
5767 : : case OMP_DEFAULTMAP_PRESENT:
5768 : : behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT;
5769 : : break;
5770 : : case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
5771 : : case OMP_DEFAULTMAP_DEFAULT:
5772 : : behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
5773 : : break;
5774 : 0 : default: gcc_unreachable ();
5775 : : }
5776 : 153 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
5777 : 153 : OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
5778 : 153 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5779 : : }
5780 : :
5781 : 31514 : if (clauses->doacross_source)
5782 : : {
5783 : 131 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
5784 : 131 : OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
5785 : 131 : OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source;
5786 : 131 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5787 : : }
5788 : :
5789 : 31514 : if (clauses->async)
5790 : : {
5791 : 549 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC);
5792 : 549 : if (clauses->async_expr)
5793 : 549 : OMP_CLAUSE_ASYNC_EXPR (c)
5794 : 1098 : = gfc_convert_expr_to_tree (block, clauses->async_expr);
5795 : : else
5796 : 0 : OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
5797 : 549 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5798 : : }
5799 : 31514 : if (clauses->seq)
5800 : : {
5801 : 140 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ);
5802 : 140 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5803 : : }
5804 : 31514 : if (clauses->par_auto)
5805 : : {
5806 : 62 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO);
5807 : 62 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5808 : : }
5809 : 31514 : if (clauses->if_present)
5810 : : {
5811 : 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT);
5812 : 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5813 : : }
5814 : 31514 : if (clauses->finalize)
5815 : : {
5816 : 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
5817 : 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5818 : : }
5819 : 31514 : if (clauses->independent)
5820 : : {
5821 : 239 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT);
5822 : 239 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5823 : : }
5824 : 31514 : if (clauses->wait_list)
5825 : : {
5826 : : gfc_expr_list *el;
5827 : :
5828 : 317 : for (el = clauses->wait_list; el; el = el->next)
5829 : : {
5830 : 172 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT);
5831 : 172 : OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
5832 : 172 : OMP_CLAUSE_CHAIN (c) = omp_clauses;
5833 : 172 : omp_clauses = c;
5834 : : }
5835 : : }
5836 : 31514 : if (clauses->num_gangs_expr)
5837 : : {
5838 : 666 : tree num_gangs_var
5839 : 666 : = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
5840 : 666 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS);
5841 : 666 : OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
5842 : 666 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5843 : : }
5844 : 31514 : if (clauses->num_workers_expr)
5845 : : {
5846 : 583 : tree num_workers_var
5847 : 583 : = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
5848 : 583 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS);
5849 : 583 : OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
5850 : 583 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5851 : : }
5852 : 31514 : if (clauses->vector_length_expr)
5853 : : {
5854 : 553 : tree vector_length_var
5855 : 553 : = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
5856 : 553 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH);
5857 : 553 : OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
5858 : 553 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5859 : : }
5860 : 31514 : if (clauses->tile_list)
5861 : : {
5862 : : tree list = NULL_TREE;
5863 : 174 : for (gfc_expr_list *el = clauses->tile_list; el; el = el->next)
5864 : 114 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
5865 : : list);
5866 : :
5867 : 60 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE);
5868 : 60 : OMP_CLAUSE_TILE_LIST (c) = nreverse (list);
5869 : 60 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5870 : : }
5871 : 31514 : if (clauses->vector)
5872 : : {
5873 : 835 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
5874 : 835 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5875 : :
5876 : 835 : if (clauses->vector_expr)
5877 : : {
5878 : 119 : tree vector_var
5879 : 119 : = gfc_convert_expr_to_tree (block, clauses->vector_expr);
5880 : 119 : OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
5881 : :
5882 : : /* TODO: We're not capturing location information for individual
5883 : : clauses. However, if we have an expression attached to the
5884 : : clause, that one provides better location information. */
5885 : 238 : OMP_CLAUSE_LOCATION (c)
5886 : 119 : = gfc_get_location (&clauses->vector_expr->where);
5887 : : }
5888 : : }
5889 : 31514 : if (clauses->worker)
5890 : : {
5891 : 730 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
5892 : 730 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5893 : :
5894 : 730 : if (clauses->worker_expr)
5895 : : {
5896 : 89 : tree worker_var
5897 : 89 : = gfc_convert_expr_to_tree (block, clauses->worker_expr);
5898 : 89 : OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
5899 : :
5900 : : /* TODO: We're not capturing location information for individual
5901 : : clauses. However, if we have an expression attached to the
5902 : : clause, that one provides better location information. */
5903 : 178 : OMP_CLAUSE_LOCATION (c)
5904 : 89 : = gfc_get_location (&clauses->worker_expr->where);
5905 : : }
5906 : : }
5907 : 31514 : if (clauses->gang)
5908 : : {
5909 : 1010 : tree arg;
5910 : 1010 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG);
5911 : 1010 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5912 : :
5913 : 1010 : if (clauses->gang_num_expr)
5914 : : {
5915 : 101 : arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
5916 : 101 : OMP_CLAUSE_GANG_EXPR (c) = arg;
5917 : :
5918 : : /* TODO: We're not capturing location information for individual
5919 : : clauses. However, if we have an expression attached to the
5920 : : clause, that one provides better location information. */
5921 : 202 : OMP_CLAUSE_LOCATION (c)
5922 : 101 : = gfc_get_location (&clauses->gang_num_expr->where);
5923 : : }
5924 : :
5925 : 1010 : if (clauses->gang_static)
5926 : : {
5927 : 15 : arg = clauses->gang_static_expr
5928 : 104 : ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
5929 : : : integer_minus_one_node;
5930 : 104 : OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
5931 : : }
5932 : : }
5933 : 31514 : if (clauses->bind != OMP_BIND_UNSET)
5934 : : {
5935 : 30 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
5936 : 30 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5937 : 30 : switch (clauses->bind)
5938 : : {
5939 : 10 : case OMP_BIND_TEAMS:
5940 : 10 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
5941 : 10 : break;
5942 : 15 : case OMP_BIND_PARALLEL:
5943 : 15 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
5944 : 15 : break;
5945 : 5 : case OMP_BIND_THREAD:
5946 : 5 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
5947 : 5 : break;
5948 : 0 : default:
5949 : 0 : gcc_unreachable ();
5950 : : }
5951 : : }
5952 : : /* OpenACC 'nohost' clauses cannot appear here. */
5953 : 31514 : gcc_checking_assert (!clauses->nohost);
5954 : :
5955 : 31514 : return nreverse (omp_clauses);
5956 : : }
5957 : :
5958 : : /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
5959 : :
5960 : : static tree
5961 : 20965 : gfc_trans_omp_code (gfc_code *code, bool force_empty)
5962 : : {
5963 : 20965 : tree stmt;
5964 : :
5965 : 20965 : pushlevel ();
5966 : 20965 : stmt = gfc_trans_code (code);
5967 : 20965 : if (TREE_CODE (stmt) != BIND_EXPR)
5968 : : {
5969 : 18708 : if (!IS_EMPTY_STMT (stmt) || force_empty)
5970 : : {
5971 : 18618 : tree block = poplevel (1, 0);
5972 : 18618 : stmt = build3_v (BIND_EXPR, NULL, stmt, block);
5973 : : }
5974 : : else
5975 : 90 : poplevel (0, 0);
5976 : : }
5977 : : else
5978 : 2257 : poplevel (0, 0);
5979 : 20965 : return stmt;
5980 : : }
5981 : :
5982 : : /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
5983 : : construct. */
5984 : :
5985 : : static tree
5986 : 4187 : gfc_trans_oacc_construct (gfc_code *code)
5987 : : {
5988 : 4187 : stmtblock_t block;
5989 : 4187 : tree stmt, oacc_clauses;
5990 : 4187 : enum tree_code construct_code;
5991 : :
5992 : 4187 : switch (code->op)
5993 : : {
5994 : : case EXEC_OACC_PARALLEL:
5995 : : construct_code = OACC_PARALLEL;
5996 : : break;
5997 : : case EXEC_OACC_KERNELS:
5998 : : construct_code = OACC_KERNELS;
5999 : : break;
6000 : : case EXEC_OACC_SERIAL:
6001 : : construct_code = OACC_SERIAL;
6002 : : break;
6003 : : case EXEC_OACC_DATA:
6004 : : construct_code = OACC_DATA;
6005 : : break;
6006 : : case EXEC_OACC_HOST_DATA:
6007 : : construct_code = OACC_HOST_DATA;
6008 : : break;
6009 : 0 : default:
6010 : 0 : gcc_unreachable ();
6011 : : }
6012 : :
6013 : 4187 : gfc_start_block (&block);
6014 : 4187 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6015 : : code->loc, false, true);
6016 : 4187 : pushlevel ();
6017 : 4187 : stmt = gfc_trans_omp_code (code->block->next, true);
6018 : 4187 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6019 : 4187 : stmt = build2_loc (gfc_get_location (&code->loc), construct_code,
6020 : : void_type_node, stmt, oacc_clauses);
6021 : 4187 : gfc_add_expr_to_block (&block, stmt);
6022 : 4187 : return gfc_finish_block (&block);
6023 : : }
6024 : :
6025 : : /* update, enter_data, exit_data, cache. */
6026 : : static tree
6027 : 2126 : gfc_trans_oacc_executable_directive (gfc_code *code)
6028 : : {
6029 : 2126 : stmtblock_t block;
6030 : 2126 : tree stmt, oacc_clauses;
6031 : 2126 : enum tree_code construct_code;
6032 : :
6033 : 2126 : switch (code->op)
6034 : : {
6035 : : case EXEC_OACC_UPDATE:
6036 : : construct_code = OACC_UPDATE;
6037 : : break;
6038 : 785 : case EXEC_OACC_ENTER_DATA:
6039 : 785 : construct_code = OACC_ENTER_DATA;
6040 : 785 : break;
6041 : 573 : case EXEC_OACC_EXIT_DATA:
6042 : 573 : construct_code = OACC_EXIT_DATA;
6043 : 573 : break;
6044 : 76 : case EXEC_OACC_CACHE:
6045 : 76 : construct_code = OACC_CACHE;
6046 : 76 : break;
6047 : 0 : default:
6048 : 0 : gcc_unreachable ();
6049 : : }
6050 : :
6051 : 2126 : gfc_start_block (&block);
6052 : 2126 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6053 : : code->loc, false, true, code->op);
6054 : 2126 : stmt = build1_loc (input_location, construct_code, void_type_node,
6055 : : oacc_clauses);
6056 : 2126 : gfc_add_expr_to_block (&block, stmt);
6057 : 2126 : return gfc_finish_block (&block);
6058 : : }
6059 : :
6060 : : static tree
6061 : 173 : gfc_trans_oacc_wait_directive (gfc_code *code)
6062 : : {
6063 : 173 : stmtblock_t block;
6064 : 173 : tree stmt, t;
6065 : 173 : vec<tree, va_gc> *args;
6066 : 173 : int nparms = 0;
6067 : 173 : gfc_expr_list *el;
6068 : 173 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
6069 : 173 : location_t loc = input_location;
6070 : :
6071 : 303 : for (el = clauses->wait_list; el; el = el->next)
6072 : 130 : nparms++;
6073 : :
6074 : 173 : vec_alloc (args, nparms + 2);
6075 : 173 : stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
6076 : :
6077 : 173 : gfc_start_block (&block);
6078 : :
6079 : 173 : if (clauses->async_expr)
6080 : 3 : t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
6081 : : else
6082 : 170 : t = build_int_cst (integer_type_node, -2);
6083 : :
6084 : 173 : args->quick_push (t);
6085 : 173 : args->quick_push (build_int_cst (integer_type_node, nparms));
6086 : :
6087 : 303 : for (el = clauses->wait_list; el; el = el->next)
6088 : 130 : args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
6089 : :
6090 : 173 : stmt = build_call_expr_loc_vec (loc, stmt, args);
6091 : 173 : if (clauses->if_expr)
6092 : 6 : stmt = build3_loc (input_location, COND_EXPR, void_type_node,
6093 : : gfc_convert_expr_to_tree (&block, clauses->if_expr),
6094 : : stmt, NULL_TREE);
6095 : 173 : gfc_add_expr_to_block (&block, stmt);
6096 : :
6097 : 173 : vec_free (args);
6098 : :
6099 : 173 : return gfc_finish_block (&block);
6100 : : }
6101 : :
6102 : : static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
6103 : : static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
6104 : :
6105 : : static tree
6106 : 34 : gfc_trans_omp_allocators (gfc_code *code)
6107 : : {
6108 : 34 : static bool warned = false;
6109 : 34 : gfc_omp_namelist *omp_allocate
6110 : 34 : = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6111 : 34 : if (!flag_openmp_allocators && !warned)
6112 : : {
6113 : 2 : omp_allocate = NULL;
6114 : 2 : gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>",
6115 : 2 : code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS",
6116 : : &code->loc);
6117 : 2 : warning (0, "All files that might deallocate such a variable must be "
6118 : : "compiled with %<-fopenmp-allocators%>");
6119 : 2 : inform (UNKNOWN_LOCATION,
6120 : : "This includes explicit DEALLOCATE, reallocation on intrinsic "
6121 : : "assignment, INTENT(OUT) for allocatable dummy arguments, and "
6122 : : "reallocation of allocatable components allocated with an "
6123 : : "OpenMP allocator");
6124 : 2 : warned = true;
6125 : : }
6126 : 34 : return gfc_trans_allocate (code->block->next, omp_allocate);
6127 : : }
6128 : :
6129 : : static tree
6130 : 10 : gfc_trans_omp_assume (gfc_code *code)
6131 : : {
6132 : 10 : stmtblock_t block;
6133 : 10 : gfc_init_block (&block);
6134 : 10 : gfc_omp_assumptions *assume = code->ext.omp_clauses->assume;
6135 : 10 : if (assume)
6136 : 19 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
6137 : : {
6138 : 9 : location_t loc = gfc_get_location (&el->expr->where);
6139 : 9 : gfc_se se;
6140 : 9 : gfc_init_se (&se, NULL);
6141 : 9 : gfc_conv_expr (&se, el->expr);
6142 : 9 : tree t;
6143 : 9 : if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE)
6144 : 8 : t = se.expr;
6145 : : else
6146 : : {
6147 : 1 : tree var = create_tmp_var_raw (boolean_type_node);
6148 : 1 : DECL_CONTEXT (var) = current_function_decl;
6149 : 1 : stmtblock_t block2;
6150 : 1 : gfc_init_block (&block2);
6151 : 1 : gfc_add_block_to_block (&block2, &se.pre);
6152 : 1 : gfc_add_modify_loc (loc, &block2, var,
6153 : : fold_convert_loc (loc, boolean_type_node,
6154 : : se.expr));
6155 : 1 : gfc_add_block_to_block (&block2, &se.post);
6156 : 1 : t = gfc_finish_block (&block2);
6157 : 1 : t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL);
6158 : : }
6159 : 9 : t = build_call_expr_internal_loc (loc, IFN_ASSUME,
6160 : : void_type_node, 1, t);
6161 : 9 : gfc_add_expr_to_block (&block, t);
6162 : : }
6163 : 10 : gfc_add_expr_to_block (&block, gfc_trans_omp_code (code->block->next, true));
6164 : 10 : return gfc_finish_block (&block);
6165 : : }
6166 : :
6167 : : static tree
6168 : 2596 : gfc_trans_omp_atomic (gfc_code *code)
6169 : : {
6170 : 2596 : gfc_code *atomic_code = code->block;
6171 : 2596 : gfc_se lse;
6172 : 2596 : gfc_se rse;
6173 : 2596 : gfc_se vse;
6174 : 2596 : gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
6175 : 2596 : gfc_symbol *var;
6176 : 2596 : stmtblock_t block;
6177 : 2596 : tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
6178 : 2596 : enum tree_code op = ERROR_MARK;
6179 : 2596 : enum tree_code aop = OMP_ATOMIC;
6180 : 2596 : bool var_on_left = false, else_branch = false;
6181 : 2596 : enum omp_memory_order mo, fail_mo;
6182 : 2596 : switch (atomic_code->ext.omp_clauses->memorder)
6183 : : {
6184 : : case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
6185 : : case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
6186 : : case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
6187 : : case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
6188 : : case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
6189 : : case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
6190 : 0 : default: gcc_unreachable ();
6191 : : }
6192 : 2596 : switch (atomic_code->ext.omp_clauses->fail)
6193 : : {
6194 : : case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
6195 : 14 : case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
6196 : 26 : case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
6197 : 2 : case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
6198 : 0 : default: gcc_unreachable ();
6199 : : }
6200 : 2596 : mo = (omp_memory_order) (mo | fail_mo);
6201 : :
6202 : 2596 : code = code->block->next;
6203 : 2596 : if (atomic_code->ext.omp_clauses->compare)
6204 : : {
6205 : 144 : gfc_expr *comp_expr;
6206 : 144 : if (code->op == EXEC_IF)
6207 : : {
6208 : 125 : comp_expr = code->block->expr1;
6209 : 125 : gcc_assert (code->block->next->op == EXEC_ASSIGN);
6210 : 125 : expr1 = code->block->next->expr1;
6211 : 125 : expr2 = code->block->next->expr2;
6212 : 125 : if (code->block->block)
6213 : : {
6214 : 64 : gcc_assert (atomic_code->ext.omp_clauses->capture
6215 : : && code->block->block->next->op == EXEC_ASSIGN);
6216 : 64 : else_branch = true;
6217 : 64 : aop = OMP_ATOMIC_CAPTURE_OLD;
6218 : 64 : capture_expr1 = code->block->block->next->expr1;
6219 : 64 : capture_expr2 = code->block->block->next->expr2;
6220 : : }
6221 : 61 : else if (atomic_code->ext.omp_clauses->capture)
6222 : : {
6223 : 19 : gcc_assert (code->next->op == EXEC_ASSIGN);
6224 : 19 : aop = OMP_ATOMIC_CAPTURE_NEW;
6225 : 19 : capture_expr1 = code->next->expr1;
6226 : 19 : capture_expr2 = code->next->expr2;
6227 : : }
6228 : : }
6229 : : else
6230 : : {
6231 : 19 : gcc_assert (atomic_code->ext.omp_clauses->capture
6232 : : && code->op == EXEC_ASSIGN
6233 : : && code->next->op == EXEC_IF);
6234 : 19 : aop = OMP_ATOMIC_CAPTURE_OLD;
6235 : 19 : capture_expr1 = code->expr1;
6236 : 19 : capture_expr2 = code->expr2;
6237 : 19 : expr1 = code->next->block->next->expr1;
6238 : 19 : expr2 = code->next->block->next->expr2;
6239 : 19 : comp_expr = code->next->block->expr1;
6240 : : }
6241 : 144 : gfc_init_se (&lse, NULL);
6242 : 144 : gfc_conv_expr (&lse, comp_expr->value.op.op2);
6243 : 144 : gfc_add_block_to_block (&block, &lse.pre);
6244 : 144 : compare = lse.expr;
6245 : 144 : var = expr1->symtree->n.sym;
6246 : : }
6247 : : else
6248 : : {
6249 : 2452 : gcc_assert (code->op == EXEC_ASSIGN);
6250 : 2452 : expr1 = code->expr1;
6251 : 2452 : expr2 = code->expr2;
6252 : 2452 : if (atomic_code->ext.omp_clauses->capture
6253 : 463 : && (expr2->expr_type == EXPR_VARIABLE
6254 : 245 : || (expr2->expr_type == EXPR_FUNCTION
6255 : 113 : && expr2->value.function.isym
6256 : 113 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION
6257 : 41 : && (expr2->value.function.actual->expr->expr_type
6258 : : == EXPR_VARIABLE))))
6259 : : {
6260 : 235 : capture_expr1 = expr1;
6261 : 235 : capture_expr2 = expr2;
6262 : 235 : expr1 = code->next->expr1;
6263 : 235 : expr2 = code->next->expr2;
6264 : 235 : aop = OMP_ATOMIC_CAPTURE_OLD;
6265 : : }
6266 : 2217 : else if (atomic_code->ext.omp_clauses->capture)
6267 : : {
6268 : 228 : aop = OMP_ATOMIC_CAPTURE_NEW;
6269 : 228 : capture_expr1 = code->next->expr1;
6270 : 228 : capture_expr2 = code->next->expr2;
6271 : : }
6272 : 2452 : var = expr1->symtree->n.sym;
6273 : : }
6274 : :
6275 : 2596 : gfc_init_se (&lse, NULL);
6276 : 2596 : gfc_init_se (&rse, NULL);
6277 : 2596 : gfc_init_se (&vse, NULL);
6278 : 2596 : gfc_start_block (&block);
6279 : :
6280 : 2596 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6281 : : != GFC_OMP_ATOMIC_WRITE)
6282 : 2190 : && expr2->expr_type == EXPR_FUNCTION
6283 : 472 : && expr2->value.function.isym
6284 : 472 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6285 : 139 : expr2 = expr2->value.function.actual->expr;
6286 : :
6287 : 2596 : if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6288 : : == GFC_OMP_ATOMIC_READ)
6289 : : {
6290 : 494 : gfc_conv_expr (&vse, expr1);
6291 : 494 : gfc_add_block_to_block (&block, &vse.pre);
6292 : :
6293 : 494 : gfc_conv_expr (&lse, expr2);
6294 : 494 : gfc_add_block_to_block (&block, &lse.pre);
6295 : 494 : type = TREE_TYPE (lse.expr);
6296 : 494 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6297 : :
6298 : 494 : x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
6299 : 494 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6300 : 494 : x = convert (TREE_TYPE (vse.expr), x);
6301 : 494 : gfc_add_modify (&block, vse.expr, x);
6302 : :
6303 : 494 : gfc_add_block_to_block (&block, &lse.pre);
6304 : 494 : gfc_add_block_to_block (&block, &rse.pre);
6305 : :
6306 : 494 : return gfc_finish_block (&block);
6307 : : }
6308 : :
6309 : 2102 : if (capture_expr2
6310 : 565 : && capture_expr2->expr_type == EXPR_FUNCTION
6311 : 21 : && capture_expr2->value.function.isym
6312 : 21 : && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6313 : 21 : capture_expr2 = capture_expr2->value.function.actual->expr;
6314 : 565 : gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
6315 : :
6316 : 2102 : if (aop == OMP_ATOMIC_CAPTURE_OLD)
6317 : : {
6318 : 318 : gfc_conv_expr (&vse, capture_expr1);
6319 : 318 : gfc_add_block_to_block (&block, &vse.pre);
6320 : 318 : gfc_conv_expr (&lse, capture_expr2);
6321 : 318 : gfc_add_block_to_block (&block, &lse.pre);
6322 : 318 : gfc_init_se (&lse, NULL);
6323 : : }
6324 : :
6325 : 2102 : gfc_conv_expr (&lse, expr1);
6326 : 2102 : gfc_add_block_to_block (&block, &lse.pre);
6327 : 2102 : type = TREE_TYPE (lse.expr);
6328 : 2102 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6329 : :
6330 : 2102 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6331 : : == GFC_OMP_ATOMIC_WRITE)
6332 : 1696 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6333 : 1674 : || compare)
6334 : : {
6335 : 572 : gfc_conv_expr (&rse, expr2);
6336 : 572 : gfc_add_block_to_block (&block, &rse.pre);
6337 : : }
6338 : 1530 : else if (expr2->expr_type == EXPR_OP)
6339 : : {
6340 : 1184 : gfc_expr *e;
6341 : 1184 : switch (expr2->value.op.op)
6342 : : {
6343 : : case INTRINSIC_PLUS:
6344 : : op = PLUS_EXPR;
6345 : : break;
6346 : 91 : case INTRINSIC_TIMES:
6347 : 91 : op = MULT_EXPR;
6348 : 91 : break;
6349 : 113 : case INTRINSIC_MINUS:
6350 : 113 : op = MINUS_EXPR;
6351 : 113 : break;
6352 : 91 : case INTRINSIC_DIVIDE:
6353 : 91 : if (expr2->ts.type == BT_INTEGER)
6354 : : op = TRUNC_DIV_EXPR;
6355 : : else
6356 : 74 : op = RDIV_EXPR;
6357 : : break;
6358 : 43 : case INTRINSIC_AND:
6359 : 43 : op = TRUTH_ANDIF_EXPR;
6360 : 43 : break;
6361 : 49 : case INTRINSIC_OR:
6362 : 49 : op = TRUTH_ORIF_EXPR;
6363 : 49 : break;
6364 : 43 : case INTRINSIC_EQV:
6365 : 43 : op = EQ_EXPR;
6366 : 43 : break;
6367 : 43 : case INTRINSIC_NEQV:
6368 : 43 : op = NE_EXPR;
6369 : 43 : break;
6370 : 0 : default:
6371 : 0 : gcc_unreachable ();
6372 : : }
6373 : 1184 : e = expr2->value.op.op1;
6374 : 1184 : if (e->expr_type == EXPR_FUNCTION
6375 : 48 : && e->value.function.isym
6376 : 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6377 : 48 : e = e->value.function.actual->expr;
6378 : 1184 : if (e->expr_type == EXPR_VARIABLE
6379 : 925 : && e->symtree != NULL
6380 : 925 : && e->symtree->n.sym == var)
6381 : : {
6382 : 910 : expr2 = expr2->value.op.op2;
6383 : 910 : var_on_left = true;
6384 : : }
6385 : : else
6386 : : {
6387 : 274 : e = expr2->value.op.op2;
6388 : 274 : if (e->expr_type == EXPR_FUNCTION
6389 : 48 : && e->value.function.isym
6390 : 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6391 : 48 : e = e->value.function.actual->expr;
6392 : 274 : gcc_assert (e->expr_type == EXPR_VARIABLE
6393 : : && e->symtree != NULL
6394 : : && e->symtree->n.sym == var);
6395 : : expr2 = expr2->value.op.op1;
6396 : : var_on_left = false;
6397 : : }
6398 : 1184 : gfc_conv_expr (&rse, expr2);
6399 : 1184 : gfc_add_block_to_block (&block, &rse.pre);
6400 : : }
6401 : : else
6402 : : {
6403 : 346 : gcc_assert (expr2->expr_type == EXPR_FUNCTION);
6404 : 346 : switch (expr2->value.function.isym->id)
6405 : : {
6406 : : case GFC_ISYM_MIN:
6407 : : op = MIN_EXPR;
6408 : : break;
6409 : 114 : case GFC_ISYM_MAX:
6410 : 114 : op = MAX_EXPR;
6411 : 114 : break;
6412 : 47 : case GFC_ISYM_IAND:
6413 : 47 : op = BIT_AND_EXPR;
6414 : 47 : break;
6415 : 49 : case GFC_ISYM_IOR:
6416 : 49 : op = BIT_IOR_EXPR;
6417 : 49 : break;
6418 : 45 : case GFC_ISYM_IEOR:
6419 : 45 : op = BIT_XOR_EXPR;
6420 : 45 : break;
6421 : 0 : default:
6422 : 0 : gcc_unreachable ();
6423 : : }
6424 : 346 : e = expr2->value.function.actual->expr;
6425 : 346 : if (e->expr_type == EXPR_FUNCTION
6426 : 13 : && e->value.function.isym
6427 : 13 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6428 : 13 : e = e->value.function.actual->expr;
6429 : 346 : gcc_assert (e->expr_type == EXPR_VARIABLE
6430 : : && e->symtree != NULL
6431 : : && e->symtree->n.sym == var);
6432 : :
6433 : 346 : gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
6434 : 346 : gfc_add_block_to_block (&block, &rse.pre);
6435 : 346 : if (expr2->value.function.actual->next->next != NULL)
6436 : : {
6437 : 26 : tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
6438 : 26 : gfc_actual_arglist *arg;
6439 : :
6440 : 26 : gfc_add_modify (&block, accum, rse.expr);
6441 : 64 : for (arg = expr2->value.function.actual->next->next; arg;
6442 : 38 : arg = arg->next)
6443 : : {
6444 : 38 : gfc_init_block (&rse.pre);
6445 : 38 : gfc_conv_expr (&rse, arg->expr);
6446 : 38 : gfc_add_block_to_block (&block, &rse.pre);
6447 : 38 : x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
6448 : : accum, rse.expr);
6449 : 38 : gfc_add_modify (&block, accum, x);
6450 : : }
6451 : :
6452 : 26 : rse.expr = accum;
6453 : : }
6454 : :
6455 : 346 : expr2 = expr2->value.function.actual->next->expr;
6456 : : }
6457 : :
6458 : 2102 : lhsaddr = save_expr (lhsaddr);
6459 : 2102 : if (TREE_CODE (lhsaddr) != SAVE_EXPR
6460 : 2102 : && (TREE_CODE (lhsaddr) != ADDR_EXPR
6461 : 1642 : || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
6462 : : {
6463 : : /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
6464 : : it even after unsharing function body. */
6465 : 44 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6466 : 44 : DECL_CONTEXT (var) = current_function_decl;
6467 : 44 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
6468 : : NULL_TREE, NULL_TREE);
6469 : : }
6470 : :
6471 : 2102 : if (compare)
6472 : : {
6473 : 144 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6474 : 144 : DECL_CONTEXT (var) = current_function_decl;
6475 : 144 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
6476 : : NULL);
6477 : 144 : lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
6478 : 144 : compare = convert (TREE_TYPE (lse.expr), compare);
6479 : 144 : compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6480 : : lse.expr, compare);
6481 : : }
6482 : :
6483 : 2102 : if (expr2->expr_type == EXPR_VARIABLE || compare)
6484 : 460 : rhs = rse.expr;
6485 : : else
6486 : 1642 : rhs = gfc_evaluate_now (rse.expr, &block);
6487 : :
6488 : 2102 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6489 : : == GFC_OMP_ATOMIC_WRITE)
6490 : 1696 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6491 : 1674 : || compare)
6492 : : x = rhs;
6493 : : else
6494 : : {
6495 : 1530 : x = convert (TREE_TYPE (rhs),
6496 : : build_fold_indirect_ref_loc (input_location, lhsaddr));
6497 : 1530 : if (var_on_left)
6498 : 910 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
6499 : : else
6500 : 620 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
6501 : : }
6502 : :
6503 : 2102 : if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
6504 : 2102 : && TREE_CODE (type) != COMPLEX_TYPE)
6505 : 0 : x = fold_build1_loc (input_location, REALPART_EXPR,
6506 : 0 : TREE_TYPE (TREE_TYPE (rhs)), x);
6507 : :
6508 : 2102 : gfc_add_block_to_block (&block, &lse.pre);
6509 : 2102 : gfc_add_block_to_block (&block, &rse.pre);
6510 : :
6511 : 2102 : if (aop == OMP_ATOMIC_CAPTURE_NEW)
6512 : : {
6513 : 247 : gfc_conv_expr (&vse, capture_expr1);
6514 : 247 : gfc_add_block_to_block (&block, &vse.pre);
6515 : 247 : gfc_add_block_to_block (&block, &lse.pre);
6516 : : }
6517 : :
6518 : 2102 : if (compare && else_branch)
6519 : : {
6520 : 64 : tree var2 = create_tmp_var_raw (boolean_type_node);
6521 : 64 : DECL_CONTEXT (var2) = current_function_decl;
6522 : 64 : comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
6523 : : boolean_false_node, NULL, NULL);
6524 : 64 : compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
6525 : : var2, compare);
6526 : 64 : TREE_OPERAND (compare, 0) = comp_tgt;
6527 : 64 : compare = omit_one_operand_loc (input_location, boolean_type_node,
6528 : : compare, comp_tgt);
6529 : : }
6530 : :
6531 : 2102 : if (compare)
6532 : 144 : x = build3_loc (input_location, COND_EXPR, type, compare,
6533 : : convert (type, x), lse.expr);
6534 : :
6535 : 2102 : if (aop == OMP_ATOMIC)
6536 : : {
6537 : 1537 : x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
6538 : 1537 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6539 : 1537 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6540 : 1537 : gfc_add_expr_to_block (&block, x);
6541 : : }
6542 : : else
6543 : : {
6544 : 565 : x = build2 (aop, type, lhsaddr, convert (type, x));
6545 : 565 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6546 : 565 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6547 : 565 : if (compare && else_branch)
6548 : : {
6549 : 64 : tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
6550 : 64 : DECL_CONTEXT (vtmp) = current_function_decl;
6551 : 64 : x = fold_build2_loc (input_location, MODIFY_EXPR,
6552 : 64 : TREE_TYPE (vtmp), vtmp, x);
6553 : 64 : vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
6554 : 64 : build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
6555 : 64 : TREE_OPERAND (x, 0) = vtmp;
6556 : 64 : tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
6557 : 64 : x2 = fold_build2_loc (input_location, MODIFY_EXPR,
6558 : 64 : TREE_TYPE (vse.expr), vse.expr, x2);
6559 : 64 : x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
6560 : : void_node, x2);
6561 : 64 : x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
6562 : 64 : gfc_add_expr_to_block (&block, x);
6563 : : }
6564 : : else
6565 : : {
6566 : 501 : x = convert (TREE_TYPE (vse.expr), x);
6567 : 501 : gfc_add_modify (&block, vse.expr, x);
6568 : : }
6569 : : }
6570 : :
6571 : 2102 : return gfc_finish_block (&block);
6572 : : }
6573 : :
6574 : : static tree
6575 : 603 : gfc_trans_omp_barrier (void)
6576 : : {
6577 : 603 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
6578 : 603 : return build_call_expr_loc (input_location, decl, 0);
6579 : : }
6580 : :
6581 : : static tree
6582 : 310 : gfc_trans_omp_cancel (gfc_code *code)
6583 : : {
6584 : 310 : int mask = 0;
6585 : 310 : tree ifc = boolean_true_node;
6586 : 310 : stmtblock_t block;
6587 : 310 : switch (code->ext.omp_clauses->cancel)
6588 : : {
6589 : : case OMP_CANCEL_PARALLEL: mask = 1; break;
6590 : : case OMP_CANCEL_DO: mask = 2; break;
6591 : : case OMP_CANCEL_SECTIONS: mask = 4; break;
6592 : : case OMP_CANCEL_TASKGROUP: mask = 8; break;
6593 : 0 : default: gcc_unreachable ();
6594 : : }
6595 : 310 : gfc_start_block (&block);
6596 : 310 : if (code->ext.omp_clauses->if_expr
6597 : 219 : || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
6598 : : {
6599 : 99 : gfc_se se;
6600 : 99 : tree if_var;
6601 : :
6602 : 99 : gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
6603 : : ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
6604 : 99 : gfc_init_se (&se, NULL);
6605 : 99 : gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL
6606 : : ? code->ext.omp_clauses->if_expr
6607 : : : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
6608 : 99 : gfc_add_block_to_block (&block, &se.pre);
6609 : 99 : if_var = gfc_evaluate_now (se.expr, &block);
6610 : 99 : gfc_add_block_to_block (&block, &se.post);
6611 : 99 : tree type = TREE_TYPE (if_var);
6612 : 99 : ifc = fold_build2_loc (input_location, NE_EXPR,
6613 : : boolean_type_node, if_var,
6614 : : build_zero_cst (type));
6615 : : }
6616 : 310 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
6617 : 310 : tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
6618 : 310 : ifc = fold_convert (c_bool_type, ifc);
6619 : 310 : gfc_add_expr_to_block (&block,
6620 : : build_call_expr_loc (input_location, decl, 2,
6621 : : build_int_cst (integer_type_node,
6622 : 310 : mask), ifc));
6623 : 310 : return gfc_finish_block (&block);
6624 : : }
6625 : :
6626 : : static tree
6627 : 170 : gfc_trans_omp_cancellation_point (gfc_code *code)
6628 : : {
6629 : 170 : int mask = 0;
6630 : 170 : switch (code->ext.omp_clauses->cancel)
6631 : : {
6632 : : case OMP_CANCEL_PARALLEL: mask = 1; break;
6633 : : case OMP_CANCEL_DO: mask = 2; break;
6634 : : case OMP_CANCEL_SECTIONS: mask = 4; break;
6635 : : case OMP_CANCEL_TASKGROUP: mask = 8; break;
6636 : 0 : default: gcc_unreachable ();
6637 : : }
6638 : 170 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
6639 : 170 : return build_call_expr_loc (input_location, decl, 1,
6640 : 340 : build_int_cst (integer_type_node, mask));
6641 : : }
6642 : :
6643 : : static tree
6644 : 143 : gfc_trans_omp_critical (gfc_code *code)
6645 : : {
6646 : 143 : stmtblock_t block;
6647 : 143 : tree stmt, name = NULL_TREE;
6648 : 143 : if (code->ext.omp_clauses->critical_name != NULL)
6649 : 36 : name = get_identifier (code->ext.omp_clauses->critical_name);
6650 : 143 : gfc_start_block (&block);
6651 : 143 : stmt = make_node (OMP_CRITICAL);
6652 : 143 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
6653 : 143 : TREE_TYPE (stmt) = void_type_node;
6654 : 143 : OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
6655 : 143 : OMP_CRITICAL_NAME (stmt) = name;
6656 : 143 : OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
6657 : : code->ext.omp_clauses,
6658 : : code->loc);
6659 : 143 : gfc_add_expr_to_block (&block, stmt);
6660 : 143 : return gfc_finish_block (&block);
6661 : : }
6662 : :
6663 : : typedef struct dovar_init_d {
6664 : : gfc_symbol *sym;
6665 : : tree var;
6666 : : tree init;
6667 : : bool non_unit_iter;
6668 : : } dovar_init;
6669 : :
6670 : : static bool
6671 : 2884 : gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
6672 : : gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
6673 : : int simple, gfc_expr *curr_loop_var)
6674 : : {
6675 : 2884 : int i;
6676 : 4771 : for (i = 0; i < loop_n; i++)
6677 : : {
6678 : 2441 : gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
6679 : 2441 : if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
6680 : : break;
6681 : 1887 : code = code->block->next;
6682 : : }
6683 : 2884 : if (i >= loop_n)
6684 : : return false;
6685 : :
6686 : : /* Canonical format: TREE_VEC with [var, multiplier, offset]. */
6687 : 554 : gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
6688 : :
6689 : 554 : tree tree_var = NULL_TREE;
6690 : 554 : tree a1 = integer_one_node;
6691 : 554 : tree a2 = integer_zero_node;
6692 : :
6693 : 554 : if (!simple)
6694 : : {
6695 : : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
6696 : 6 : sorry_at (gfc_get_location (&curr_loop_var->where),
6697 : : "non-rectangular loop nest with non-constant step for %qs",
6698 : 3 : curr_loop_var->symtree->n.sym->name);
6699 : 3 : return false;
6700 : : }
6701 : :
6702 : : dovar_init *di;
6703 : : unsigned ix;
6704 : 551 : FOR_EACH_VEC_ELT (*inits, ix, di)
6705 : 18 : if (di->sym == var)
6706 : : {
6707 : 18 : if (!di->non_unit_iter)
6708 : : {
6709 : 16 : tree_var = di->init;
6710 : 16 : gcc_assert (DECL_P (tree_var));
6711 : : break;
6712 : : }
6713 : : else
6714 : : {
6715 : : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
6716 : 2 : sorry_at (gfc_get_location (&code->loc),
6717 : : "non-rectangular loop nest with non-constant step "
6718 : : "for %qs", var->name);
6719 : 2 : inform (gfc_get_location (&expr->where), "Used here");
6720 : 2 : return false;
6721 : : }
6722 : : }
6723 : 533 : if (tree_var == NULL_TREE)
6724 : 533 : tree_var = var->backend_decl;
6725 : :
6726 : 549 : if (expr->expr_type == EXPR_VARIABLE)
6727 : 54 : gcc_assert (expr->symtree->n.sym == var);
6728 : 495 : else if (expr->expr_type != EXPR_OP
6729 : 495 : || (expr->value.op.op != INTRINSIC_TIMES
6730 : 479 : && expr->value.op.op != INTRINSIC_PLUS
6731 : 359 : && expr->value.op.op != INTRINSIC_MINUS))
6732 : 0 : gcc_unreachable ();
6733 : : else
6734 : : {
6735 : 495 : gfc_se se;
6736 : 495 : gfc_expr *et = NULL, *eo = NULL, *e = expr;
6737 : 495 : if (expr->value.op.op != INTRINSIC_TIMES)
6738 : : {
6739 : 479 : if (gfc_find_sym_in_expr (var, expr->value.op.op1))
6740 : : {
6741 : 431 : e = expr->value.op.op1;
6742 : 431 : eo = expr->value.op.op2;
6743 : : }
6744 : : else
6745 : : {
6746 : 48 : eo = expr->value.op.op1;
6747 : 48 : e = expr->value.op.op2;
6748 : : }
6749 : : }
6750 : 495 : if (e->value.op.op == INTRINSIC_TIMES)
6751 : : {
6752 : 91 : if (e->value.op.op1->expr_type == EXPR_VARIABLE
6753 : 91 : && e->value.op.op1->symtree->n.sym == var)
6754 : 51 : et = e->value.op.op2;
6755 : : else
6756 : : {
6757 : 40 : et = e->value.op.op1;
6758 : 40 : gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
6759 : : && e->value.op.op2->symtree->n.sym == var);
6760 : : }
6761 : : }
6762 : : else
6763 : 404 : gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
6764 : 91 : if (et != NULL)
6765 : : {
6766 : 91 : gfc_init_se (&se, NULL);
6767 : 91 : gfc_conv_expr_val (&se, et);
6768 : 91 : gfc_add_block_to_block (pblock, &se.pre);
6769 : 91 : a1 = se.expr;
6770 : : }
6771 : 495 : if (eo != NULL)
6772 : : {
6773 : 479 : gfc_init_se (&se, NULL);
6774 : 479 : gfc_conv_expr_val (&se, eo);
6775 : 479 : gfc_add_block_to_block (pblock, &se.pre);
6776 : 479 : a2 = se.expr;
6777 : 479 : if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
6778 : : /* outer-var - a2. */
6779 : 335 : a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
6780 : 144 : else if (expr->value.op.op == INTRINSIC_MINUS)
6781 : : /* a2 - outer-var. */
6782 : 24 : a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
6783 : : }
6784 : 495 : a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
6785 : 495 : a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
6786 : : }
6787 : :
6788 : 549 : gfc_init_se (sep, NULL);
6789 : 549 : sep->expr = make_tree_vec (3);
6790 : 549 : TREE_VEC_ELT (sep->expr, 0) = tree_var;
6791 : 549 : TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
6792 : 549 : TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
6793 : :
6794 : 549 : return true;
6795 : : }
6796 : :
6797 : : int
6798 : 708 : gfc_expr_list_len (gfc_expr_list *list)
6799 : : {
6800 : 708 : unsigned len = 0;
6801 : 2092 : for (; list; list = list->next)
6802 : 1384 : len++;
6803 : :
6804 : 708 : return len;
6805 : : }
6806 : :
6807 : : static tree
6808 : 9526 : gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
6809 : : gfc_omp_clauses *do_clauses, tree par_clauses)
6810 : : {
6811 : 9526 : gfc_se se;
6812 : 9526 : tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
6813 : 9526 : tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
6814 : 9526 : stmtblock_t block;
6815 : 9526 : stmtblock_t body;
6816 : 9526 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
6817 : 9526 : int i, collapse = clauses->collapse;
6818 : 9526 : vec<dovar_init> inits = vNULL;
6819 : 9526 : dovar_init *di;
6820 : 9526 : unsigned ix;
6821 : 9526 : vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
6822 : 19052 : gfc_expr_list *oacc_tile
6823 : 9526 : = do_clauses ? do_clauses->tile_list : clauses->tile_list;
6824 : 9526 : gfc_expr_list *sizes
6825 : : = do_clauses ? do_clauses->sizes_list : clauses->sizes_list;
6826 : 9526 : gfc_code *orig_code = code;
6827 : :
6828 : : /* Both collapsed and tiled loops are lowered the same way. In
6829 : : OpenACC, those clauses are not compatible, so prioritize the tile
6830 : : clause, if present. */
6831 : 9526 : if (oacc_tile)
6832 : 60 : collapse = gfc_expr_list_len (oacc_tile);
6833 : 9466 : else if (sizes)
6834 : 120 : collapse = gfc_expr_list_len (sizes);
6835 : :
6836 : 9526 : doacross_steps = NULL;
6837 : 9526 : if (clauses->orderedc)
6838 : 133 : collapse = clauses->orderedc;
6839 : 9526 : if (collapse <= 0)
6840 : : collapse = 1;
6841 : :
6842 : 9526 : code = code->block->next;
6843 : :
6844 : 9526 : init = make_tree_vec (collapse);
6845 : 9526 : cond = make_tree_vec (collapse);
6846 : 9526 : incr = make_tree_vec (collapse);
6847 : 9526 : orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE;
6848 : :
6849 : 9526 : if (pblock == NULL)
6850 : : {
6851 : 6032 : gfc_start_block (&block);
6852 : 6032 : pblock = █
6853 : : }
6854 : :
6855 : : /* simd schedule modifier is only useful for composite do simd and other
6856 : : constructs including that, where gfc_trans_omp_do is only called
6857 : : on the simd construct and DO's clauses are translated elsewhere. */
6858 : 9526 : do_clauses->sched_simd = false;
6859 : :
6860 : 9526 : omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
6861 : :
6862 : 21543 : for (i = 0; i < collapse; i++)
6863 : : {
6864 : 12017 : int simple = 0;
6865 : 12017 : int dovar_found = 0;
6866 : 12017 : tree dovar_decl;
6867 : :
6868 : 12017 : if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
6869 : : {
6870 : 320 : TREE_VEC_ELT (init, i) = NULL_TREE;
6871 : 320 : TREE_VEC_ELT (cond, i) = NULL_TREE;
6872 : 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
6873 : 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
6874 : 320 : if (orig_decls)
6875 : 2 : TREE_VEC_ELT (orig_decls, i) = NULL_TREE;
6876 : 320 : continue;
6877 : : }
6878 : 11697 : gcc_assert (code->op == EXEC_DO);
6879 : 11697 : if (clauses)
6880 : : {
6881 : 11697 : gfc_omp_namelist *n = NULL;
6882 : 11697 : if (op == EXEC_OMP_SIMD && collapse == 1)
6883 : 936 : for (n = clauses->lists[OMP_LIST_LINEAR];
6884 : 1236 : n != NULL; n = n->next)
6885 : 443 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
6886 : : {
6887 : : dovar_found = 3;
6888 : : break;
6889 : : }
6890 : 11697 : if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
6891 : 11460 : for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
6892 : 13519 : n != NULL; n = n->next)
6893 : 3436 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
6894 : : {
6895 : : dovar_found = 2;
6896 : : break;
6897 : : }
6898 : 11697 : if (n == NULL)
6899 : 11433 : for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
6900 : 6990 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
6901 : : {
6902 : : dovar_found = 1;
6903 : : break;
6904 : : }
6905 : : }
6906 : :
6907 : : /* Evaluate all the expressions in the iterator. */
6908 : 11697 : gfc_init_se (&se, NULL);
6909 : 11697 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
6910 : 11697 : gfc_add_block_to_block (pblock, &se.pre);
6911 : 11697 : local_dovar = dovar_decl = dovar = se.expr;
6912 : 11697 : type = TREE_TYPE (dovar);
6913 : 11697 : gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
6914 : :
6915 : 11697 : gfc_init_se (&se, NULL);
6916 : 11697 : gfc_conv_expr_val (&se, code->ext.iterator->step);
6917 : 11697 : gfc_add_block_to_block (pblock, &se.pre);
6918 : 11697 : step = gfc_evaluate_now (se.expr, pblock);
6919 : :
6920 : 11697 : if (TREE_CODE (step) == INTEGER_CST)
6921 : 11106 : simple = tree_int_cst_sgn (step);
6922 : :
6923 : 11697 : gfc_init_se (&se, NULL);
6924 : 11697 : if (!clauses->non_rectangular
6925 : 13139 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
6926 : : code->ext.iterator->start, &inits, simple,
6927 : 1442 : code->ext.iterator->var))
6928 : : {
6929 : 11381 : gfc_conv_expr_val (&se, code->ext.iterator->start);
6930 : 11381 : gfc_add_block_to_block (pblock, &se.pre);
6931 : 11381 : if (!DECL_P (se.expr))
6932 : 10983 : se.expr = gfc_evaluate_now (se.expr, pblock);
6933 : : }
6934 : 11697 : from = se.expr;
6935 : :
6936 : 11697 : gfc_init_se (&se, NULL);
6937 : 11697 : if (!clauses->non_rectangular
6938 : 13139 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
6939 : : code->ext.iterator->end, &inits, simple,
6940 : 1442 : code->ext.iterator->var))
6941 : : {
6942 : 11464 : gfc_conv_expr_val (&se, code->ext.iterator->end);
6943 : 11464 : gfc_add_block_to_block (pblock, &se.pre);
6944 : 11464 : if (!DECL_P (se.expr))
6945 : 10229 : se.expr = gfc_evaluate_now (se.expr, pblock);
6946 : : }
6947 : 11697 : to = se.expr;
6948 : :
6949 : 11697 : if (!DECL_P (dovar))
6950 : 38 : dovar_decl
6951 : 38 : = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
6952 : : false);
6953 : 11697 : if (simple && !DECL_P (dovar))
6954 : : {
6955 : 38 : const char *name = code->ext.iterator->var->symtree->n.sym->name;
6956 : 38 : local_dovar = gfc_create_var (type, name);
6957 : 38 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
6958 : 38 : dovar, local_dovar, false};
6959 : 38 : inits.safe_push (e);
6960 : : }
6961 : : /* Loop body. */
6962 : 11697 : if (simple)
6963 : : {
6964 : 11106 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
6965 : : /* The condition should not be folded. */
6966 : 11658 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
6967 : : ? LE_EXPR : GE_EXPR,
6968 : : logical_type_node, local_dovar,
6969 : : to);
6970 : 11106 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
6971 : : type, local_dovar, step);
6972 : 11106 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
6973 : : MODIFY_EXPR,
6974 : : type, local_dovar,
6975 : 11106 : TREE_VEC_ELT (incr, i));
6976 : 11106 : if (orig_decls && !clauses->orderedc)
6977 : : orig_decls = NULL;
6978 : 382 : else if (orig_decls)
6979 : 382 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
6980 : : }
6981 : : else
6982 : : {
6983 : : /* STEP is not 1 or -1. Use:
6984 : : for (count = 0; count < (to + step - from) / step; count++)
6985 : : {
6986 : : dovar = from + count * step;
6987 : : body;
6988 : : cycle_label:;
6989 : : } */
6990 : 591 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
6991 : 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
6992 : 591 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
6993 : : step);
6994 : 591 : tmp = gfc_evaluate_now (tmp, pblock);
6995 : 591 : local_dovar = gfc_create_var (type, "count");
6996 : 591 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
6997 : : build_int_cst (type, 0));
6998 : : /* The condition should not be folded. */
6999 : 591 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
7000 : : logical_type_node,
7001 : : local_dovar, tmp);
7002 : 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
7003 : : type, local_dovar,
7004 : : build_int_cst (type, 1));
7005 : 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
7006 : : MODIFY_EXPR, type,
7007 : : local_dovar,
7008 : 591 : TREE_VEC_ELT (incr, i));
7009 : :
7010 : : /* Initialize DOVAR. */
7011 : 591 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
7012 : : step);
7013 : 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
7014 : 591 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
7015 : 591 : dovar, tmp, true};
7016 : 591 : inits.safe_push (e);
7017 : 591 : if (clauses->orderedc)
7018 : : {
7019 : 192 : if (doacross_steps == NULL)
7020 : 47 : vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true);
7021 : 192 : (*doacross_steps)[i] = step;
7022 : : }
7023 : 591 : if (orig_decls)
7024 : 198 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
7025 : : }
7026 : :
7027 : 11697 : if (dovar_found == 3
7028 : 11697 : && op == EXEC_OMP_SIMD
7029 : 143 : && collapse == 1
7030 : 143 : && local_dovar != dovar)
7031 : : {
7032 : 120 : for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
7033 : 120 : if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
7034 : 120 : && OMP_CLAUSE_DECL (tmp) == dovar)
7035 : : {
7036 : 30 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7037 : 30 : break;
7038 : : }
7039 : : }
7040 : 11697 : if (!dovar_found && op == EXEC_OMP_SIMD)
7041 : : {
7042 : 1356 : if (collapse == 1)
7043 : : {
7044 : 783 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7045 : 783 : OMP_CLAUSE_LINEAR_STEP (tmp) = step;
7046 : 783 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7047 : 783 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7048 : 783 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7049 : 783 : if (local_dovar != dovar)
7050 : : dovar_found = 3;
7051 : : }
7052 : : }
7053 : 10341 : else if (!dovar_found && local_dovar != dovar)
7054 : : {
7055 : 260 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7056 : 260 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7057 : 260 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7058 : : }
7059 : 11667 : if (dovar_found > 1)
7060 : : {
7061 : 1550 : tree c = NULL;
7062 : :
7063 : 1550 : tmp = NULL;
7064 : 1550 : if (local_dovar != dovar)
7065 : : {
7066 : : /* If dovar is lastprivate, but different counter is used,
7067 : : dovar += step needs to be added to
7068 : : OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
7069 : : will have the value on entry of the last loop, rather
7070 : : than value after iterator increment. */
7071 : 243 : if (clauses->orderedc)
7072 : : {
7073 : 60 : if (clauses->collapse <= 1 || i >= clauses->collapse)
7074 : : tmp = local_dovar;
7075 : : else
7076 : 36 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7077 : : type, local_dovar,
7078 : : build_one_cst (type));
7079 : 60 : tmp = fold_build2_loc (input_location, MULT_EXPR, type,
7080 : : tmp, step);
7081 : 60 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7082 : : from, tmp);
7083 : : }
7084 : : else
7085 : 183 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7086 : : dovar, step);
7087 : 243 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
7088 : : dovar, tmp);
7089 : 934 : for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7090 : 613 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7091 : 613 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7092 : : {
7093 : 105 : OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
7094 : 105 : break;
7095 : : }
7096 : 508 : else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
7097 : 508 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7098 : : {
7099 : 60 : OMP_CLAUSE_LINEAR_STMT (c) = tmp;
7100 : 60 : break;
7101 : : }
7102 : : }
7103 : 1550 : if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
7104 : : {
7105 : 892 : for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7106 : 892 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7107 : 892 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7108 : : {
7109 : 406 : tree l = build_omp_clause (input_location,
7110 : : OMP_CLAUSE_LASTPRIVATE);
7111 : 406 : if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
7112 : 4 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
7113 : 406 : OMP_CLAUSE_DECL (l) = dovar_decl;
7114 : 406 : OMP_CLAUSE_CHAIN (l) = omp_clauses;
7115 : 406 : OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
7116 : 406 : omp_clauses = l;
7117 : 406 : OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
7118 : 406 : break;
7119 : : }
7120 : : }
7121 : 1550 : gcc_assert (local_dovar == dovar || c != NULL);
7122 : : }
7123 : 11697 : if (local_dovar != dovar)
7124 : : {
7125 : 629 : if (op != EXEC_OMP_SIMD || dovar_found == 1)
7126 : 550 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7127 : 79 : else if (collapse == 1)
7128 : : {
7129 : 60 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7130 : 60 : OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
7131 : 60 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7132 : 60 : OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
7133 : : }
7134 : : else
7135 : 19 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
7136 : 629 : OMP_CLAUSE_DECL (tmp) = local_dovar;
7137 : 629 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7138 : : }
7139 : :
7140 : 11697 : if (i + 1 < collapse)
7141 : 2463 : code = code->block->next;
7142 : : }
7143 : :
7144 : 9526 : if (pblock != &block)
7145 : : {
7146 : 3494 : pushlevel ();
7147 : 3494 : gfc_start_block (&block);
7148 : : }
7149 : :
7150 : 9526 : gfc_start_block (&body);
7151 : :
7152 : 19681 : FOR_EACH_VEC_ELT (inits, ix, di)
7153 : 629 : gfc_add_modify (&body, di->var, di->init);
7154 : 9526 : inits.release ();
7155 : :
7156 : : /* Cycle statement is implemented with a goto. Exit statement must not be
7157 : : present for this loop. */
7158 : 9526 : cycle_label = gfc_build_label_decl (NULL_TREE);
7159 : :
7160 : : /* Put these labels where they can be found later. */
7161 : :
7162 : 9526 : code->cycle_label = cycle_label;
7163 : 9526 : code->exit_label = NULL_TREE;
7164 : :
7165 : : /* Main loop body. */
7166 : 9526 : if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7167 : : {
7168 : 16 : gfc_code *code1, *scan, *code2, *tmpcode;
7169 : 16 : code1 = tmpcode = code->block->next;
7170 : 16 : if (tmpcode && tmpcode->op != EXEC_OMP_SCAN)
7171 : 18 : while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN)
7172 : : tmpcode = tmpcode->next;
7173 : 16 : scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next;
7174 : 16 : if (code1 != scan)
7175 : 16 : tmpcode->next = NULL;
7176 : 16 : code2 = scan->next;
7177 : 16 : gcc_assert (scan->op == EXEC_OMP_SCAN);
7178 : 16 : location_t loc = gfc_get_location (&scan->loc);
7179 : :
7180 : 16 : tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc);
7181 : 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
7182 : 16 : SET_EXPR_LOCATION (tmp, loc);
7183 : 16 : gfc_add_expr_to_block (&body, tmp);
7184 : 16 : input_location = loc;
7185 : 16 : tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc);
7186 : 16 : tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc);
7187 : 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
7188 : 16 : SET_EXPR_LOCATION (tmp, loc);
7189 : 16 : if (code1 != scan)
7190 : 16 : tmpcode->next = scan;
7191 : : }
7192 : 9510 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
7193 : 292 : tmp = gfc_trans_omp_code (code, true);
7194 : : else
7195 : 9218 : tmp = gfc_trans_omp_code (code->block->next, true);
7196 : 9526 : gfc_add_expr_to_block (&body, tmp);
7197 : :
7198 : : /* Label for cycle statements (if needed). */
7199 : 9526 : if (TREE_USED (cycle_label))
7200 : : {
7201 : 9526 : tmp = build1_v (LABEL_EXPR, cycle_label);
7202 : 9526 : gfc_add_expr_to_block (&body, tmp);
7203 : : }
7204 : :
7205 : : /* End of loop body. */
7206 : 9526 : switch (op)
7207 : : {
7208 : 1455 : case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
7209 : 2411 : case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
7210 : 80 : case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
7211 : 113 : case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
7212 : 94 : case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
7213 : 4931 : case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
7214 : 120 : case EXEC_OMP_TILE: stmt = make_node (OMP_TILE); break;
7215 : 322 : case EXEC_OMP_UNROLL: stmt = make_node (OMP_UNROLL); break;
7216 : 0 : default: gcc_unreachable ();
7217 : : }
7218 : :
7219 : 9526 : SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc));
7220 : 9526 : TREE_TYPE (stmt) = void_type_node;
7221 : 9526 : OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
7222 : 9526 : OMP_FOR_CLAUSES (stmt) = omp_clauses;
7223 : 9526 : OMP_FOR_INIT (stmt) = init;
7224 : 9526 : OMP_FOR_COND (stmt) = cond;
7225 : 9526 : OMP_FOR_INCR (stmt) = incr;
7226 : 9526 : if (orig_decls)
7227 : 139 : OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
7228 : 9526 : OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
7229 : 9526 : gfc_add_expr_to_block (&block, stmt);
7230 : :
7231 : 9526 : vec_free (doacross_steps);
7232 : 9526 : doacross_steps = saved_doacross_steps;
7233 : :
7234 : 9526 : return gfc_finish_block (&block);
7235 : : }
7236 : :
7237 : : /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
7238 : : construct. */
7239 : :
7240 : : static tree
7241 : 1556 : gfc_trans_oacc_combined_directive (gfc_code *code)
7242 : : {
7243 : 1556 : stmtblock_t block, *pblock = NULL;
7244 : 1556 : gfc_omp_clauses construct_clauses, loop_clauses;
7245 : 1556 : tree stmt, oacc_clauses = NULL_TREE;
7246 : 1556 : enum tree_code construct_code;
7247 : 1556 : location_t loc = input_location;
7248 : :
7249 : 1556 : switch (code->op)
7250 : : {
7251 : : case EXEC_OACC_PARALLEL_LOOP:
7252 : : construct_code = OACC_PARALLEL;
7253 : : break;
7254 : : case EXEC_OACC_KERNELS_LOOP:
7255 : : construct_code = OACC_KERNELS;
7256 : : break;
7257 : : case EXEC_OACC_SERIAL_LOOP:
7258 : : construct_code = OACC_SERIAL;
7259 : : break;
7260 : 0 : default:
7261 : 0 : gcc_unreachable ();
7262 : : }
7263 : :
7264 : 1556 : gfc_start_block (&block);
7265 : :
7266 : 1556 : memset (&loop_clauses, 0, sizeof (loop_clauses));
7267 : 1556 : if (code->ext.omp_clauses != NULL)
7268 : : {
7269 : 1556 : memcpy (&construct_clauses, code->ext.omp_clauses,
7270 : : sizeof (construct_clauses));
7271 : 1556 : loop_clauses.collapse = construct_clauses.collapse;
7272 : 1556 : loop_clauses.gang = construct_clauses.gang;
7273 : 1556 : loop_clauses.gang_static = construct_clauses.gang_static;
7274 : 1556 : loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
7275 : 1556 : loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
7276 : 1556 : loop_clauses.vector = construct_clauses.vector;
7277 : 1556 : loop_clauses.vector_expr = construct_clauses.vector_expr;
7278 : 1556 : loop_clauses.worker = construct_clauses.worker;
7279 : 1556 : loop_clauses.worker_expr = construct_clauses.worker_expr;
7280 : 1556 : loop_clauses.seq = construct_clauses.seq;
7281 : 1556 : loop_clauses.par_auto = construct_clauses.par_auto;
7282 : 1556 : loop_clauses.independent = construct_clauses.independent;
7283 : 1556 : loop_clauses.tile_list = construct_clauses.tile_list;
7284 : 1556 : loop_clauses.lists[OMP_LIST_PRIVATE]
7285 : 1556 : = construct_clauses.lists[OMP_LIST_PRIVATE];
7286 : 1556 : loop_clauses.lists[OMP_LIST_REDUCTION]
7287 : 1556 : = construct_clauses.lists[OMP_LIST_REDUCTION];
7288 : 1556 : construct_clauses.gang = false;
7289 : 1556 : construct_clauses.gang_static = false;
7290 : 1556 : construct_clauses.gang_num_expr = NULL;
7291 : 1556 : construct_clauses.gang_static_expr = NULL;
7292 : 1556 : construct_clauses.vector = false;
7293 : 1556 : construct_clauses.vector_expr = NULL;
7294 : 1556 : construct_clauses.worker = false;
7295 : 1556 : construct_clauses.worker_expr = NULL;
7296 : 1556 : construct_clauses.seq = false;
7297 : 1556 : construct_clauses.par_auto = false;
7298 : 1556 : construct_clauses.independent = false;
7299 : 1556 : construct_clauses.independent = false;
7300 : 1556 : construct_clauses.tile_list = NULL;
7301 : 1556 : construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
7302 : 1556 : if (construct_code == OACC_KERNELS)
7303 : 87 : construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
7304 : 1556 : oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
7305 : : code->loc, false, true);
7306 : : }
7307 : 1556 : if (!loop_clauses.seq)
7308 : : pblock = █
7309 : : else
7310 : 54 : pushlevel ();
7311 : 1556 : stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
7312 : 1556 : protected_set_expr_location (stmt, loc);
7313 : 1556 : if (TREE_CODE (stmt) != BIND_EXPR)
7314 : 1556 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7315 : : else
7316 : 0 : poplevel (0, 0);
7317 : 1556 : stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses);
7318 : 1556 : gfc_add_expr_to_block (&block, stmt);
7319 : 1556 : return gfc_finish_block (&block);
7320 : : }
7321 : :
7322 : : static tree
7323 : 108 : gfc_trans_omp_depobj (gfc_code *code)
7324 : : {
7325 : 108 : stmtblock_t block;
7326 : 108 : gfc_se se;
7327 : 108 : gfc_init_se (&se, NULL);
7328 : 108 : gfc_init_block (&block);
7329 : 108 : gfc_conv_expr (&se, code->ext.omp_clauses->depobj);
7330 : 108 : gcc_assert (se.pre.head == NULL && se.post.head == NULL);
7331 : 108 : tree depobj = se.expr;
7332 : 108 : location_t loc = EXPR_LOCATION (depobj);
7333 : 108 : if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
7334 : 108 : depobj = gfc_build_addr_expr (NULL, depobj);
7335 : 108 : depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
7336 : : TYPE_MODE (ptr_type_node),
7337 : : true), depobj);
7338 : 108 : gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
7339 : 108 : if (n)
7340 : : {
7341 : 83 : tree var;
7342 : 83 : if (!n->sym) /* omp_all_memory. */
7343 : 3 : var = null_pointer_node;
7344 : 80 : else if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
7345 : : {
7346 : 18 : gfc_init_se (&se, NULL);
7347 : 18 : if (n->expr->ref->u.ar.type == AR_ELEMENT)
7348 : : {
7349 : 18 : gfc_conv_expr_reference (&se, n->expr);
7350 : 18 : var = se.expr;
7351 : : }
7352 : : else
7353 : : {
7354 : 0 : gfc_conv_expr_descriptor (&se, n->expr);
7355 : 0 : var = gfc_conv_array_data (se.expr);
7356 : : }
7357 : 18 : gfc_add_block_to_block (&block, &se.pre);
7358 : 18 : gfc_add_block_to_block (&block, &se.post);
7359 : 18 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7360 : : }
7361 : : else
7362 : : {
7363 : 62 : var = gfc_get_symbol_decl (n->sym);
7364 : 99 : if (POINTER_TYPE_P (TREE_TYPE (var))
7365 : 72 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
7366 : 8 : var = build_fold_indirect_ref (var);
7367 : 62 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
7368 : : {
7369 : 12 : var = gfc_conv_descriptor_data_get (var);
7370 : 12 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7371 : : }
7372 : 50 : else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
7373 : 13 : && n->sym->attr.dummy)
7374 : 8 : var = build_fold_indirect_ref (var);
7375 : 67 : else if (!POINTER_TYPE_P (TREE_TYPE (var))
7376 : 44 : || (n->sym->ts.f90_type == BT_VOID
7377 : 12 : && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
7378 : 8 : && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
7379 : : {
7380 : 29 : TREE_ADDRESSABLE (var) = 1;
7381 : 29 : var = gfc_build_addr_expr (NULL, var);
7382 : : }
7383 : : }
7384 : 83 : depobj = save_expr (depobj);
7385 : 83 : tree r = build_fold_indirect_ref_loc (loc, depobj);
7386 : 83 : gfc_add_expr_to_block (&block,
7387 : : build2 (MODIFY_EXPR, void_type_node, r, var));
7388 : : }
7389 : :
7390 : : /* Only one may be set. */
7391 : 108 : gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
7392 : : + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
7393 : : == 1);
7394 : 108 : int k = -1; /* omp_clauses->destroy */
7395 : 108 : if (!code->ext.omp_clauses->destroy)
7396 : 92 : switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
7397 : 92 : ? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op)
7398 : : {
7399 : : case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
7400 : : case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
7401 : : case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
7402 : : case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break;
7403 : : case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
7404 : 0 : default: gcc_unreachable ();
7405 : : }
7406 : 108 : tree t = build_int_cst (ptr_type_node, k);
7407 : 108 : depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj,
7408 : 108 : TYPE_SIZE_UNIT (ptr_type_node));
7409 : 108 : depobj = build_fold_indirect_ref_loc (loc, depobj);
7410 : 108 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
7411 : :
7412 : 108 : return gfc_finish_block (&block);
7413 : : }
7414 : :
7415 : : /* Callback for walk_tree to find an OMP dispatch call and wrap it into an
7416 : : * IFN_GOMP_DISPATCH. */
7417 : :
7418 : : static tree
7419 : 2066 : replace_omp_dispatch_call (tree *tp, int *, void *decls_p)
7420 : : {
7421 : 2066 : tree t = *tp;
7422 : 2066 : tree decls = (tree) decls_p;
7423 : 2066 : tree orig_fn_decl = TREE_PURPOSE (decls);
7424 : 2066 : tree dup_fn_decl = TREE_VALUE (decls);
7425 : 2066 : if (TREE_CODE (t) == CALL_EXPR)
7426 : : {
7427 : 141 : if (CALL_EXPR_FN (t) == dup_fn_decl)
7428 : 1 : CALL_EXPR_FN (t) = orig_fn_decl;
7429 : 140 : else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR
7430 : 140 : && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl)
7431 : 127 : TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl;
7432 : : else
7433 : : return NULL_TREE;
7434 : 128 : *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH,
7435 : 128 : TREE_TYPE (t), 1, t);
7436 : 128 : return *tp;
7437 : : }
7438 : :
7439 : : return NULL_TREE;
7440 : : }
7441 : :
7442 : : static tree
7443 : 128 : gfc_trans_omp_dispatch (gfc_code *code)
7444 : : {
7445 : 128 : stmtblock_t block;
7446 : 128 : gfc_code *next = code->block->next;
7447 : : // assume ill-formed "function dispatch structured
7448 : : // block" have already been rejected by resolve_omp_dispatch
7449 : 128 : gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
7450 : :
7451 : : // Make duplicate decl for dispatch function call to make it easy to spot
7452 : : // after translation
7453 : 128 : gfc_symbol *orig_fn_sym;
7454 : 128 : gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2;
7455 : 128 : if (call_expr != NULL) // function
7456 : : {
7457 : 71 : if (call_expr->value.function.isym != NULL) // dig into convert intrinsics
7458 : 4 : call_expr = call_expr->value.function.actual->expr;
7459 : 71 : gcc_assert (call_expr->expr_type == EXPR_FUNCTION);
7460 : 71 : orig_fn_sym = call_expr->value.function.esym
7461 : 71 : ? call_expr->value.function.esym
7462 : 0 : : call_expr->symtree->n.sym;
7463 : : }
7464 : : else // subroutine
7465 : : {
7466 : 57 : orig_fn_sym = next->resolved_sym;
7467 : : }
7468 : 128 : if (!orig_fn_sym->backend_decl)
7469 : 25 : gfc_get_symbol_decl (orig_fn_sym);
7470 : 128 : gfc_symbol dup_fn_sym = *orig_fn_sym;
7471 : 128 : dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl);
7472 : 128 : if (call_expr != NULL)
7473 : 71 : call_expr->value.function.esym = &dup_fn_sym;
7474 : : else
7475 : 57 : next->resolved_sym = &dup_fn_sym;
7476 : :
7477 : 128 : tree body = gfc_trans_code (next);
7478 : :
7479 : : // Walk the tree to find the duplicate decl, wrap IFN call and replace
7480 : : // dup decl with original
7481 : 128 : tree fn_decls
7482 : 128 : = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl);
7483 : 128 : tree dispatch_call
7484 : 128 : = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL);
7485 : 128 : gcc_assert (dispatch_call != NULL_TREE);
7486 : :
7487 : 128 : gfc_start_block (&block);
7488 : 128 : tree omp_clauses
7489 : 128 : = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
7490 : :
7491 : : // Extract depend clauses and create taskwait
7492 : 128 : tree depend_clauses = NULL_TREE;
7493 : 128 : tree *depend_clauses_ptr = &depend_clauses;
7494 : 333 : for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c))
7495 : : {
7496 : 205 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND)
7497 : : {
7498 : 8 : *depend_clauses_ptr = c;
7499 : 8 : depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c);
7500 : : }
7501 : : }
7502 : 128 : if (depend_clauses != NULL_TREE)
7503 : : {
7504 : 4 : tree stmt = make_node (OMP_TASK);
7505 : 4 : TREE_TYPE (stmt) = void_node;
7506 : 4 : OMP_TASK_CLAUSES (stmt) = depend_clauses;
7507 : 4 : OMP_TASK_BODY (stmt) = NULL_TREE;
7508 : 4 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7509 : 4 : gfc_add_expr_to_block (&block, stmt);
7510 : : }
7511 : :
7512 : 128 : tree stmt = make_node (OMP_DISPATCH);
7513 : 128 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7514 : 128 : TREE_TYPE (stmt) = void_type_node;
7515 : 128 : OMP_DISPATCH_BODY (stmt) = body;
7516 : 128 : OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
7517 : :
7518 : 128 : gfc_add_expr_to_block (&block, stmt);
7519 : 128 : return gfc_finish_block (&block);
7520 : : }
7521 : :
7522 : : static tree
7523 : 29 : gfc_trans_omp_error (gfc_code *code)
7524 : : {
7525 : 29 : stmtblock_t block;
7526 : 29 : gfc_se se;
7527 : 29 : tree len, message;
7528 : 29 : bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
7529 : 42 : tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
7530 : : : BUILT_IN_GOMP_WARNING);
7531 : 29 : gfc_start_block (&block);
7532 : 29 : gfc_init_se (&se, NULL );
7533 : 29 : if (!code->ext.omp_clauses->message)
7534 : : {
7535 : 3 : message = null_pointer_node;
7536 : 3 : len = build_int_cst (size_type_node, 0);
7537 : : }
7538 : : else
7539 : : {
7540 : 26 : gfc_conv_expr (&se, code->ext.omp_clauses->message);
7541 : 26 : message = se.expr;
7542 : 26 : if (!POINTER_TYPE_P (TREE_TYPE (message)))
7543 : : /* To ensure an ARRAY_TYPE is not passed as such. */
7544 : 17 : message = gfc_build_addr_expr (NULL, message);
7545 : 26 : len = se.string_length;
7546 : : }
7547 : 29 : gfc_add_block_to_block (&block, &se.pre);
7548 : 29 : gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
7549 : : 2, message, len));
7550 : 29 : gfc_add_block_to_block (&block, &se.post);
7551 : 29 : return gfc_finish_block (&block);
7552 : : }
7553 : :
7554 : : static tree
7555 : 70 : gfc_trans_omp_flush (gfc_code *code)
7556 : : {
7557 : 70 : tree call;
7558 : 70 : if (!code->ext.omp_clauses
7559 : 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
7560 : 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
7561 : : {
7562 : 67 : call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
7563 : 67 : call = build_call_expr_loc (input_location, call, 0);
7564 : : }
7565 : : else
7566 : : {
7567 : 3 : enum memmodel mo = MEMMODEL_LAST;
7568 : 3 : switch (code->ext.omp_clauses->memorder)
7569 : : {
7570 : : case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
7571 : : case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
7572 : : case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
7573 : 0 : default: gcc_unreachable (); break;
7574 : : }
7575 : 3 : call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE);
7576 : 3 : call = build_call_expr_loc (input_location, call, 1,
7577 : 3 : build_int_cst (integer_type_node, mo));
7578 : : }
7579 : 70 : return call;
7580 : : }
7581 : :
7582 : : static tree
7583 : 115 : gfc_trans_omp_master (gfc_code *code)
7584 : : {
7585 : 115 : tree stmt = gfc_trans_code (code->block->next);
7586 : 115 : if (IS_EMPTY_STMT (stmt))
7587 : : return stmt;
7588 : 109 : return build1_v (OMP_MASTER, stmt);
7589 : : }
7590 : :
7591 : : static tree
7592 : 49 : gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
7593 : : {
7594 : 49 : stmtblock_t block;
7595 : 49 : tree body = gfc_trans_code (code->block->next);
7596 : 49 : if (IS_EMPTY_STMT (body))
7597 : : return body;
7598 : 40 : if (!clauses)
7599 : 33 : clauses = code->ext.omp_clauses;
7600 : 40 : gfc_start_block (&block);
7601 : 40 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
7602 : 40 : tree stmt = make_node (OMP_MASKED);
7603 : 40 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7604 : 40 : TREE_TYPE (stmt) = void_type_node;
7605 : 40 : OMP_MASKED_BODY (stmt) = body;
7606 : 40 : OMP_MASKED_CLAUSES (stmt) = omp_clauses;
7607 : 40 : gfc_add_expr_to_block (&block, stmt);
7608 : 40 : return gfc_finish_block (&block);
7609 : : }
7610 : :
7611 : :
7612 : : static tree
7613 : 519 : gfc_trans_omp_ordered (gfc_code *code)
7614 : : {
7615 : 519 : if (!flag_openmp)
7616 : : {
7617 : 5 : if (!code->ext.omp_clauses->simd)
7618 : 3 : return gfc_trans_code (code->block ? code->block->next : NULL);
7619 : 2 : code->ext.omp_clauses->threads = 0;
7620 : : }
7621 : 516 : tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
7622 : : code->loc);
7623 : 516 : return build2_loc (input_location, OMP_ORDERED, void_type_node,
7624 : 516 : code->block ? gfc_trans_code (code->block->next)
7625 : 516 : : NULL_TREE, omp_clauses);
7626 : : }
7627 : :
7628 : : static tree
7629 : 1865 : gfc_trans_omp_parallel (gfc_code *code)
7630 : : {
7631 : 1865 : stmtblock_t block;
7632 : 1865 : tree stmt, omp_clauses;
7633 : :
7634 : 1865 : gfc_start_block (&block);
7635 : 1865 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
7636 : : code->loc);
7637 : 1865 : pushlevel ();
7638 : 1865 : stmt = gfc_trans_omp_code (code->block->next, true);
7639 : 1865 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7640 : 1865 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
7641 : : omp_clauses);
7642 : 1865 : gfc_add_expr_to_block (&block, stmt);
7643 : 1865 : return gfc_finish_block (&block);
7644 : : }
7645 : :
7646 : : enum
7647 : : {
7648 : : GFC_OMP_SPLIT_SIMD,
7649 : : GFC_OMP_SPLIT_DO,
7650 : : GFC_OMP_SPLIT_PARALLEL,
7651 : : GFC_OMP_SPLIT_DISTRIBUTE,
7652 : : GFC_OMP_SPLIT_TEAMS,
7653 : : GFC_OMP_SPLIT_TARGET,
7654 : : GFC_OMP_SPLIT_TASKLOOP,
7655 : : GFC_OMP_SPLIT_MASKED,
7656 : : GFC_OMP_SPLIT_NUM
7657 : : };
7658 : :
7659 : : enum
7660 : : {
7661 : : GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
7662 : : GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
7663 : : GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
7664 : : GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
7665 : : GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
7666 : : GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
7667 : : GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
7668 : : GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
7669 : : };
7670 : :
7671 : : /* If a var is in lastprivate/firstprivate/reduction but not in a
7672 : : data mapping/sharing clause, add it to 'map(tofrom:' if is_target
7673 : : and to 'shared' otherwise. */
7674 : : static void
7675 : 2527 : gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
7676 : : gfc_omp_clauses *clauses_in,
7677 : : bool is_target, bool is_parallel_do)
7678 : : {
7679 : 2527 : int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
7680 : 2527 : gfc_omp_namelist *tail = NULL;
7681 : 15162 : for (int i = 0; i < 5; ++i)
7682 : : {
7683 : 12635 : gfc_omp_namelist *n;
7684 : 12635 : switch (i)
7685 : : {
7686 : 2527 : case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
7687 : 2527 : case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
7688 : 2527 : case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
7689 : 2527 : case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
7690 : 2527 : case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
7691 : : default: gcc_unreachable ();
7692 : : }
7693 : 15974 : for (; n != NULL; n = n->next)
7694 : : {
7695 : : gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
7696 : 20666 : for (int j = 0; j < 6; ++j)
7697 : : {
7698 : 18197 : gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
7699 : 18197 : switch (j)
7700 : : {
7701 : 3339 : case 0:
7702 : 3339 : n2ref = &clauses_out->lists[clauselist_to_add];
7703 : 3339 : break;
7704 : 3302 : case 1:
7705 : 3302 : n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
7706 : 3302 : break;
7707 : 3302 : case 2:
7708 : 3302 : if (is_target)
7709 : 255 : n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
7710 : : else
7711 : 3047 : n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
7712 : : break;
7713 : 3302 : case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
7714 : 2476 : case 4:
7715 : 2476 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
7716 : 2476 : break;
7717 : 2476 : case 5:
7718 : 2476 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
7719 : 2476 : break;
7720 : : default: gcc_unreachable ();
7721 : : }
7722 : 28471 : for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
7723 : 13538 : if (n2->sym == n->sym)
7724 : : break;
7725 : 18197 : if (n2)
7726 : : {
7727 : 3264 : if (j == 0 /* clauselist_to_add */)
7728 : : break; /* Already present. */
7729 : 3227 : if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
7730 : : {
7731 : 1128 : n_firstp = prev2 ? &prev2->next : n2ref;
7732 : 1128 : continue;
7733 : : }
7734 : 2099 : if (j == 2 /* OMP_LIST_LASTPRIVATE */)
7735 : : {
7736 : 1266 : n_lastp = prev2 ? &prev2->next : n2ref;
7737 : 1266 : continue;
7738 : : }
7739 : : break;
7740 : : }
7741 : : }
7742 : 3339 : if (n_firstp && n_lastp)
7743 : : {
7744 : : /* For parallel do, GCC puts firstprivate/lastprivate
7745 : : on the parallel. */
7746 : 283 : if (is_parallel_do)
7747 : 280 : continue;
7748 : 3 : *n_firstp = (*n_firstp)->next;
7749 : 3 : if (!is_target)
7750 : 0 : *n_lastp = (*n_lastp)->next;
7751 : : }
7752 : 3056 : else if (is_target && n_lastp)
7753 : : ;
7754 : 3001 : else if (n2 || n_firstp || n_lastp)
7755 : 2643 : continue;
7756 : 416 : if (clauses_out->lists[clauselist_to_add]
7757 : 305 : && (clauses_out->lists[clauselist_to_add]
7758 : 305 : == clauses_in->lists[clauselist_to_add]))
7759 : : {
7760 : : gfc_omp_namelist *p = NULL;
7761 : 421 : for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
7762 : : {
7763 : 273 : if (p)
7764 : : {
7765 : 125 : p->next = gfc_get_omp_namelist ();
7766 : 125 : p = p->next;
7767 : : }
7768 : : else
7769 : : {
7770 : 148 : p = gfc_get_omp_namelist ();
7771 : 148 : clauses_out->lists[clauselist_to_add] = p;
7772 : : }
7773 : 273 : *p = *n2;
7774 : : }
7775 : : }
7776 : 416 : if (!tail)
7777 : : {
7778 : 287 : tail = clauses_out->lists[clauselist_to_add];
7779 : 412 : for (; tail && tail->next; tail = tail->next)
7780 : : ;
7781 : : }
7782 : 416 : n2 = gfc_get_omp_namelist ();
7783 : 416 : n2->where = n->where;
7784 : 416 : n2->sym = n->sym;
7785 : 416 : if (is_target)
7786 : 119 : n2->u.map.op = OMP_MAP_TOFROM;
7787 : 416 : if (tail)
7788 : : {
7789 : 305 : tail->next = n2;
7790 : 305 : tail = n2;
7791 : : }
7792 : : else
7793 : 111 : clauses_out->lists[clauselist_to_add] = n2;
7794 : : }
7795 : : }
7796 : 2527 : }
7797 : :
7798 : : /* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped
7799 : : in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */
7800 : :
7801 : : static void
7802 : 340 : gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out,
7803 : : gfc_omp_clauses *clauses_in)
7804 : : {
7805 : 340 : gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE];
7806 : 340 : gfc_omp_namelist **tail = NULL;
7807 : :
7808 : 490 : for (; n != NULL; n = n->next)
7809 : : {
7810 : 150 : gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP];
7811 : 192 : for (; n2 != NULL; n2 = n2->next)
7812 : 53 : if (n->sym == n2->sym)
7813 : : break;
7814 : 150 : if (n2 == NULL)
7815 : : {
7816 : 139 : gfc_omp_namelist *dup = gfc_get_omp_namelist ();
7817 : 139 : *dup = *n;
7818 : 139 : dup->next = NULL;
7819 : 139 : if (!tail)
7820 : : {
7821 : 76 : tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
7822 : 76 : while (*tail && (*tail)->next)
7823 : 0 : tail = &(*tail)->next;
7824 : : }
7825 : 139 : *tail = dup;
7826 : 139 : tail = &(*tail)->next;
7827 : : }
7828 : : }
7829 : 340 : }
7830 : :
7831 : : static void
7832 : 4081 : gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
7833 : : {
7834 : 36729 : for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
7835 : 1305920 : for (int j = 0; j < OMP_LIST_NUM; ++j)
7836 : 1273272 : if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
7837 : 1397 : for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
7838 : : {
7839 : 956 : gfc_omp_namelist *p = n;
7840 : 956 : n = n->next;
7841 : 956 : free (p);
7842 : : }
7843 : 4081 : }
7844 : :
7845 : : static void
7846 : 4081 : gfc_split_omp_clauses (gfc_code *code,
7847 : : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
7848 : : {
7849 : 4081 : int mask = 0, innermost = 0;
7850 : 4081 : bool is_loop = false;
7851 : 4081 : memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
7852 : 4081 : switch (code->op)
7853 : : {
7854 : : case EXEC_OMP_DISTRIBUTE:
7855 : : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
7856 : : break;
7857 : 38 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7858 : 38 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
7859 : 38 : innermost = GFC_OMP_SPLIT_DO;
7860 : 38 : break;
7861 : 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7862 : 28 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
7863 : : | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
7864 : 28 : innermost = GFC_OMP_SPLIT_SIMD;
7865 : 28 : break;
7866 : 47 : case EXEC_OMP_DISTRIBUTE_SIMD:
7867 : 47 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
7868 : 47 : innermost = GFC_OMP_SPLIT_SIMD;
7869 : 47 : break;
7870 : 0 : case EXEC_OMP_DO:
7871 : 0 : case EXEC_OMP_LOOP:
7872 : 0 : innermost = GFC_OMP_SPLIT_DO;
7873 : 0 : break;
7874 : 126 : case EXEC_OMP_DO_SIMD:
7875 : 126 : mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
7876 : 126 : innermost = GFC_OMP_SPLIT_SIMD;
7877 : 126 : break;
7878 : 0 : case EXEC_OMP_PARALLEL:
7879 : 0 : innermost = GFC_OMP_SPLIT_PARALLEL;
7880 : 0 : break;
7881 : 1105 : case EXEC_OMP_PARALLEL_DO:
7882 : 1105 : case EXEC_OMP_PARALLEL_LOOP:
7883 : 1105 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
7884 : 1105 : innermost = GFC_OMP_SPLIT_DO;
7885 : 1105 : break;
7886 : 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
7887 : 285 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
7888 : 285 : innermost = GFC_OMP_SPLIT_SIMD;
7889 : 285 : break;
7890 : 11 : case EXEC_OMP_PARALLEL_MASKED:
7891 : 11 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
7892 : 11 : innermost = GFC_OMP_SPLIT_MASKED;
7893 : 11 : break;
7894 : 14 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7895 : 14 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
7896 : : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
7897 : 14 : innermost = GFC_OMP_SPLIT_TASKLOOP;
7898 : 14 : break;
7899 : 20 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7900 : 20 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
7901 : 20 : innermost = GFC_OMP_SPLIT_TASKLOOP;
7902 : 20 : break;
7903 : 24 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7904 : 24 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
7905 : : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
7906 : 24 : innermost = GFC_OMP_SPLIT_SIMD;
7907 : 24 : break;
7908 : 28 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7909 : 28 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
7910 : 28 : innermost = GFC_OMP_SPLIT_SIMD;
7911 : 28 : break;
7912 : 0 : case EXEC_OMP_SIMD:
7913 : 0 : innermost = GFC_OMP_SPLIT_SIMD;
7914 : 0 : break;
7915 : 1670 : case EXEC_OMP_TARGET:
7916 : 1670 : innermost = GFC_OMP_SPLIT_TARGET;
7917 : 1670 : break;
7918 : 20 : case EXEC_OMP_TARGET_PARALLEL:
7919 : 20 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
7920 : 20 : innermost = GFC_OMP_SPLIT_PARALLEL;
7921 : 20 : break;
7922 : 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
7923 : 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
7924 : 80 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
7925 : 80 : innermost = GFC_OMP_SPLIT_DO;
7926 : 80 : break;
7927 : 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7928 : 15 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
7929 : : | GFC_OMP_MASK_SIMD;
7930 : 15 : innermost = GFC_OMP_SPLIT_SIMD;
7931 : 15 : break;
7932 : 26 : case EXEC_OMP_TARGET_SIMD:
7933 : 26 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
7934 : 26 : innermost = GFC_OMP_SPLIT_SIMD;
7935 : 26 : break;
7936 : 69 : case EXEC_OMP_TARGET_TEAMS:
7937 : 69 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
7938 : 69 : innermost = GFC_OMP_SPLIT_TEAMS;
7939 : 69 : break;
7940 : 14 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7941 : 14 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
7942 : : | GFC_OMP_MASK_DISTRIBUTE;
7943 : 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
7944 : 14 : break;
7945 : 58 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7946 : 58 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
7947 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
7948 : 58 : innermost = GFC_OMP_SPLIT_DO;
7949 : 58 : break;
7950 : 29 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7951 : 29 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
7952 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
7953 : 29 : innermost = GFC_OMP_SPLIT_SIMD;
7954 : 29 : break;
7955 : 16 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7956 : 16 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
7957 : : | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
7958 : 16 : innermost = GFC_OMP_SPLIT_SIMD;
7959 : 16 : break;
7960 : 13 : case EXEC_OMP_TARGET_TEAMS_LOOP:
7961 : 13 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
7962 : 13 : innermost = GFC_OMP_SPLIT_DO;
7963 : 13 : break;
7964 : 8 : case EXEC_OMP_MASKED_TASKLOOP:
7965 : 8 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
7966 : 8 : innermost = GFC_OMP_SPLIT_TASKLOOP;
7967 : 8 : break;
7968 : 0 : case EXEC_OMP_MASTER_TASKLOOP:
7969 : 0 : case EXEC_OMP_TASKLOOP:
7970 : 0 : innermost = GFC_OMP_SPLIT_TASKLOOP;
7971 : 0 : break;
7972 : 22 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
7973 : 22 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
7974 : 22 : innermost = GFC_OMP_SPLIT_SIMD;
7975 : 22 : break;
7976 : 46 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
7977 : 46 : case EXEC_OMP_TASKLOOP_SIMD:
7978 : 46 : mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
7979 : 46 : innermost = GFC_OMP_SPLIT_SIMD;
7980 : 46 : break;
7981 : 124 : case EXEC_OMP_TEAMS:
7982 : 124 : innermost = GFC_OMP_SPLIT_TEAMS;
7983 : 124 : break;
7984 : 14 : case EXEC_OMP_TEAMS_DISTRIBUTE:
7985 : 14 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
7986 : 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
7987 : 14 : break;
7988 : 32 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7989 : 32 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
7990 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
7991 : 32 : innermost = GFC_OMP_SPLIT_DO;
7992 : 32 : break;
7993 : 56 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7994 : 56 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
7995 : : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
7996 : 56 : innermost = GFC_OMP_SPLIT_SIMD;
7997 : 56 : break;
7998 : 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7999 : 37 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8000 : 37 : innermost = GFC_OMP_SPLIT_SIMD;
8001 : 37 : break;
8002 : : case EXEC_OMP_TEAMS_LOOP:
8003 : : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
8004 : : innermost = GFC_OMP_SPLIT_DO;
8005 : : break;
8006 : 0 : default:
8007 : 0 : gcc_unreachable ();
8008 : : }
8009 : 4075 : if (mask == 0)
8010 : : {
8011 : 1794 : clausesa[innermost] = *code->ext.omp_clauses;
8012 : 1794 : return;
8013 : : }
8014 : : /* Loops are similar to DO but still a bit different. */
8015 : 2287 : switch (code->op)
8016 : : {
8017 : 54 : case EXEC_OMP_LOOP:
8018 : 54 : case EXEC_OMP_PARALLEL_LOOP:
8019 : 54 : case EXEC_OMP_TEAMS_LOOP:
8020 : 54 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8021 : 54 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8022 : 54 : is_loop = true;
8023 : 2287 : default:
8024 : 2287 : break;
8025 : : }
8026 : 2287 : if (code->ext.omp_clauses != NULL)
8027 : : {
8028 : 2287 : if (mask & GFC_OMP_MASK_TARGET)
8029 : : {
8030 : : /* First the clauses that are unique to some constructs. */
8031 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
8032 : 340 : = code->ext.omp_clauses->lists[OMP_LIST_MAP];
8033 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
8034 : 340 : = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
8035 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR]
8036 : 340 : = code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
8037 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].device
8038 : 340 : = code->ext.omp_clauses->device;
8039 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
8040 : 340 : = code->ext.omp_clauses->thread_limit;
8041 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
8042 : 340 : = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
8043 : 2380 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
8044 : 2040 : clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
8045 : 2040 : = code->ext.omp_clauses->defaultmap[i];
8046 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
8047 : 340 : = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
8048 : : /* And this is copied to all. */
8049 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].if_expr
8050 : 340 : = code->ext.omp_clauses->if_expr;
8051 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].nowait
8052 : 340 : = code->ext.omp_clauses->nowait;
8053 : : }
8054 : 2287 : if (mask & GFC_OMP_MASK_TEAMS)
8055 : : {
8056 : : /* First the clauses that are unique to some constructs. */
8057 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
8058 : 344 : = code->ext.omp_clauses->num_teams_lower;
8059 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
8060 : 344 : = code->ext.omp_clauses->num_teams_upper;
8061 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
8062 : 344 : = code->ext.omp_clauses->thread_limit;
8063 : : /* Shared and default clauses are allowed on parallel, teams
8064 : : and taskloop. */
8065 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
8066 : 344 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8067 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
8068 : 344 : = code->ext.omp_clauses->default_sharing;
8069 : : }
8070 : 2287 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8071 : : {
8072 : : /* First the clauses that are unique to some constructs. */
8073 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
8074 : 369 : = code->ext.omp_clauses->dist_sched_kind;
8075 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
8076 : 369 : = code->ext.omp_clauses->dist_chunk_size;
8077 : : /* Duplicate collapse. */
8078 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
8079 : 369 : = code->ext.omp_clauses->collapse;
8080 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
8081 : 369 : = code->ext.omp_clauses->order_concurrent;
8082 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
8083 : 369 : = code->ext.omp_clauses->order_unconstrained;
8084 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
8085 : 369 : = code->ext.omp_clauses->order_reproducible;
8086 : : }
8087 : 2287 : if (mask & GFC_OMP_MASK_PARALLEL)
8088 : : {
8089 : : /* First the clauses that are unique to some constructs. */
8090 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
8091 : 1843 : = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
8092 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
8093 : 1843 : = code->ext.omp_clauses->num_threads;
8094 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
8095 : 1843 : = code->ext.omp_clauses->proc_bind;
8096 : : /* Shared and default clauses are allowed on parallel, teams
8097 : : and taskloop. */
8098 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
8099 : 1843 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8100 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
8101 : 1843 : = code->ext.omp_clauses->default_sharing;
8102 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
8103 : 1843 : = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
8104 : : /* And this is copied to all. */
8105 : 1843 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
8106 : 1843 : = code->ext.omp_clauses->if_expr;
8107 : : }
8108 : 2287 : if (mask & GFC_OMP_MASK_MASKED)
8109 : 79 : clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
8110 : 2287 : if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8111 : : {
8112 : : /* First the clauses that are unique to some constructs. */
8113 : 1817 : clausesa[GFC_OMP_SPLIT_DO].ordered
8114 : 1817 : = code->ext.omp_clauses->ordered;
8115 : 1817 : clausesa[GFC_OMP_SPLIT_DO].orderedc
8116 : 1817 : = code->ext.omp_clauses->orderedc;
8117 : 1817 : clausesa[GFC_OMP_SPLIT_DO].sched_kind
8118 : 1817 : = code->ext.omp_clauses->sched_kind;
8119 : 1817 : if (innermost == GFC_OMP_SPLIT_SIMD)
8120 : 539 : clausesa[GFC_OMP_SPLIT_DO].sched_simd
8121 : 539 : = code->ext.omp_clauses->sched_simd;
8122 : 1817 : clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
8123 : 1817 : = code->ext.omp_clauses->sched_monotonic;
8124 : 1817 : clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
8125 : 1817 : = code->ext.omp_clauses->sched_nonmonotonic;
8126 : 1817 : clausesa[GFC_OMP_SPLIT_DO].chunk_size
8127 : 1817 : = code->ext.omp_clauses->chunk_size;
8128 : 1817 : clausesa[GFC_OMP_SPLIT_DO].nowait
8129 : 1817 : = code->ext.omp_clauses->nowait;
8130 : : }
8131 : 1871 : if (mask & GFC_OMP_MASK_DO)
8132 : : {
8133 : 1871 : clausesa[GFC_OMP_SPLIT_DO].bind
8134 : 1871 : = code->ext.omp_clauses->bind;
8135 : : /* Duplicate collapse. */
8136 : 1871 : clausesa[GFC_OMP_SPLIT_DO].collapse
8137 : 1871 : = code->ext.omp_clauses->collapse;
8138 : 1871 : clausesa[GFC_OMP_SPLIT_DO].order_concurrent
8139 : 1871 : = code->ext.omp_clauses->order_concurrent;
8140 : 1871 : clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
8141 : 1871 : = code->ext.omp_clauses->order_unconstrained;
8142 : 1871 : clausesa[GFC_OMP_SPLIT_DO].order_reproducible
8143 : 1871 : = code->ext.omp_clauses->order_reproducible;
8144 : : }
8145 : 2287 : if (mask & GFC_OMP_MASK_SIMD)
8146 : : {
8147 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
8148 : 819 : = code->ext.omp_clauses->safelen_expr;
8149 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
8150 : 819 : = code->ext.omp_clauses->simdlen_expr;
8151 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
8152 : 819 : = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
8153 : : /* Duplicate collapse. */
8154 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].collapse
8155 : 819 : = code->ext.omp_clauses->collapse;
8156 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
8157 : 819 : = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
8158 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
8159 : 819 : = code->ext.omp_clauses->order_concurrent;
8160 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
8161 : 819 : = code->ext.omp_clauses->order_unconstrained;
8162 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
8163 : 819 : = code->ext.omp_clauses->order_reproducible;
8164 : : /* And this is copied to all. */
8165 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].if_expr
8166 : 819 : = code->ext.omp_clauses->if_expr;
8167 : : }
8168 : 2287 : if (mask & GFC_OMP_MASK_TASKLOOP)
8169 : : {
8170 : : /* First the clauses that are unique to some constructs. */
8171 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
8172 : 162 : = code->ext.omp_clauses->nogroup;
8173 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
8174 : 162 : = code->ext.omp_clauses->grainsize;
8175 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
8176 : 162 : = code->ext.omp_clauses->grainsize_strict;
8177 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
8178 : 162 : = code->ext.omp_clauses->num_tasks;
8179 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
8180 : 162 : = code->ext.omp_clauses->num_tasks_strict;
8181 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
8182 : 162 : = code->ext.omp_clauses->priority;
8183 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
8184 : 162 : = code->ext.omp_clauses->final_expr;
8185 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
8186 : 162 : = code->ext.omp_clauses->untied;
8187 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
8188 : 162 : = code->ext.omp_clauses->mergeable;
8189 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
8190 : 162 : = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
8191 : : /* And this is copied to all. */
8192 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
8193 : 162 : = code->ext.omp_clauses->if_expr;
8194 : : /* Shared and default clauses are allowed on parallel, teams
8195 : : and taskloop. */
8196 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
8197 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8198 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
8199 : 162 : = code->ext.omp_clauses->default_sharing;
8200 : : /* Duplicate collapse. */
8201 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
8202 : 162 : = code->ext.omp_clauses->collapse;
8203 : : }
8204 : : /* Private clause is supported on all constructs but master/masked,
8205 : : it is enough to put it on the innermost one except for master/masked. For
8206 : : !$ omp parallel do put it on parallel though,
8207 : : as that's what we did for OpenMP 3.1. */
8208 : 2287 : clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
8209 : : || code->op == EXEC_OMP_PARALLEL_MASTER
8210 : 1009 : || code->op == EXEC_OMP_PARALLEL_MASKED)
8211 : 998 : ? (int) GFC_OMP_SPLIT_PARALLEL
8212 : 3285 : : innermost].lists[OMP_LIST_PRIVATE]
8213 : 2287 : = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
8214 : : /* Firstprivate clause is supported on all constructs but
8215 : : simd and masked/master. Put it on the outermost of those and duplicate
8216 : : on parallel and teams. */
8217 : 2287 : if (mask & GFC_OMP_MASK_TARGET)
8218 : 340 : gfc_add_firstprivate_if_unmapped (&clausesa[GFC_OMP_SPLIT_TARGET],
8219 : : code->ext.omp_clauses);
8220 : 2287 : if (mask & GFC_OMP_MASK_TEAMS)
8221 : 344 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
8222 : 344 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8223 : 1943 : else if (mask & GFC_OMP_MASK_DISTRIBUTE)
8224 : 113 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
8225 : 113 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8226 : 2287 : if (mask & GFC_OMP_MASK_TASKLOOP)
8227 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
8228 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8229 : 2287 : if ((mask & GFC_OMP_MASK_PARALLEL)
8230 : 1843 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8231 : 1757 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
8232 : 1757 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8233 : 530 : else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8234 : 126 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
8235 : 126 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8236 : : /* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
8237 : : In parallel do{, simd} we actually want to put it on
8238 : : parallel rather than do. */
8239 : 2287 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8240 : 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
8241 : 369 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8242 : 2287 : if (mask & GFC_OMP_MASK_TASKLOOP)
8243 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
8244 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8245 : 2287 : if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
8246 : 1808 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8247 : 1722 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
8248 : 1722 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8249 : 565 : else if (mask & GFC_OMP_MASK_DO)
8250 : 180 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
8251 : 180 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8252 : 2287 : if (mask & GFC_OMP_MASK_SIMD)
8253 : 819 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
8254 : 819 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8255 : : /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
8256 : : Duplicate it on all of them, but
8257 : : - omit on do if parallel is present;
8258 : : - omit on task and parallel if loop is present;
8259 : : additionally, inscan applies to do/simd only. */
8260 : 9148 : for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
8261 : : {
8262 : 6861 : if (mask & GFC_OMP_MASK_TASKLOOP
8263 : 486 : && i != OMP_LIST_REDUCTION_INSCAN)
8264 : 324 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
8265 : 324 : = code->ext.omp_clauses->lists[i];
8266 : 6861 : if (mask & GFC_OMP_MASK_TEAMS
8267 : 1032 : && i != OMP_LIST_REDUCTION_INSCAN
8268 : 1032 : && !is_loop)
8269 : 650 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
8270 : 650 : = code->ext.omp_clauses->lists[i];
8271 : 6861 : if (mask & GFC_OMP_MASK_PARALLEL
8272 : 5529 : && i != OMP_LIST_REDUCTION_INSCAN
8273 : 3686 : && !(mask & GFC_OMP_MASK_TASKLOOP)
8274 : 3514 : && !is_loop)
8275 : 3444 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
8276 : 3444 : = code->ext.omp_clauses->lists[i];
8277 : 3417 : else if (mask & GFC_OMP_MASK_DO)
8278 : 2231 : clausesa[GFC_OMP_SPLIT_DO].lists[i]
8279 : 2231 : = code->ext.omp_clauses->lists[i];
8280 : 6861 : if (mask & GFC_OMP_MASK_SIMD)
8281 : 2457 : clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
8282 : 2457 : = code->ext.omp_clauses->lists[i];
8283 : : }
8284 : 2287 : if (mask & GFC_OMP_MASK_TARGET)
8285 : 340 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
8286 : 340 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8287 : 2287 : if (mask & GFC_OMP_MASK_TASKLOOP)
8288 : 162 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
8289 : 162 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8290 : : /* Linear clause is supported on do and simd,
8291 : : put it on the innermost one. */
8292 : 2287 : clausesa[innermost].lists[OMP_LIST_LINEAR]
8293 : 2287 : = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
8294 : : }
8295 : : /* Propagate firstprivate/lastprivate/reduction vars to
8296 : : shared (parallel, teams) and map-tofrom (target). */
8297 : 2287 : if (mask & GFC_OMP_MASK_TARGET)
8298 : 340 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET],
8299 : : code->ext.omp_clauses, true, false);
8300 : 2287 : if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
8301 : 1843 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL],
8302 : : code->ext.omp_clauses, false,
8303 : 1843 : mask & GFC_OMP_MASK_DO);
8304 : 2287 : if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
8305 : 344 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS],
8306 : : code->ext.omp_clauses, false, false);
8307 : 2287 : if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8308 : : == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8309 : 1726 : && !is_loop)
8310 : 1691 : clausesa[GFC_OMP_SPLIT_DO].nowait = true;
8311 : :
8312 : : /* Distribute allocate clause to do, parallel, distribute, teams, target
8313 : : and taskloop. The code below iterates over variables in the
8314 : : allocate list and checks if that available is also in any
8315 : : privatization clause on those construct. If yes, then we add it
8316 : : to the list of 'allocate'ed variables for that construct. If a
8317 : : variable is found in none of them then we issue an error. */
8318 : :
8319 : 2287 : if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
8320 : : {
8321 : : gfc_omp_namelist *alloc_nl, *priv_nl;
8322 : : gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
8323 : 104 : for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
8324 : 181 : alloc_nl; alloc_nl = alloc_nl->next)
8325 : : {
8326 : : bool found = false;
8327 : 728 : for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
8328 : : {
8329 : : gfc_omp_namelist *p;
8330 : : int list;
8331 : 24960 : for (list = 0; list < OMP_LIST_NUM; list++)
8332 : : {
8333 : 24336 : switch (list)
8334 : : {
8335 : 5616 : case OMP_LIST_PRIVATE:
8336 : 5616 : case OMP_LIST_FIRSTPRIVATE:
8337 : 5616 : case OMP_LIST_LASTPRIVATE:
8338 : 5616 : case OMP_LIST_REDUCTION:
8339 : 5616 : case OMP_LIST_REDUCTION_INSCAN:
8340 : 5616 : case OMP_LIST_REDUCTION_TASK:
8341 : 5616 : case OMP_LIST_IN_REDUCTION:
8342 : 5616 : case OMP_LIST_TASK_REDUCTION:
8343 : 5616 : case OMP_LIST_LINEAR:
8344 : 6092 : for (priv_nl = clausesa[i].lists[list]; priv_nl;
8345 : 476 : priv_nl = priv_nl->next)
8346 : 476 : if (alloc_nl->sym == priv_nl->sym)
8347 : : {
8348 : 131 : found = true;
8349 : 131 : p = gfc_get_omp_namelist ();
8350 : 131 : p->sym = alloc_nl->sym;
8351 : 131 : p->expr = alloc_nl->expr;
8352 : 131 : p->u.align = alloc_nl->u.align;
8353 : 131 : p->u2.allocator = alloc_nl->u2.allocator;
8354 : 131 : p->where = alloc_nl->where;
8355 : 131 : if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
8356 : : {
8357 : 109 : clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
8358 : 109 : tails[i] = p;
8359 : : }
8360 : : else
8361 : : {
8362 : 22 : tails[i]->next = p;
8363 : 22 : tails[i] = tails[i]->next;
8364 : : }
8365 : : }
8366 : : break;
8367 : : default:
8368 : : break;
8369 : : }
8370 : : }
8371 : : }
8372 : 104 : if (!found)
8373 : 1 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
8374 : : "in an explicit privatization clause",
8375 : 1 : alloc_nl->sym->name, &alloc_nl->where);
8376 : : }
8377 : : }
8378 : : }
8379 : :
8380 : : static tree
8381 : 539 : gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
8382 : : gfc_omp_clauses *clausesa, tree omp_clauses)
8383 : : {
8384 : 539 : stmtblock_t block;
8385 : 539 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8386 : 539 : tree stmt, body, omp_do_clauses = NULL_TREE;
8387 : 539 : bool free_clausesa = false;
8388 : :
8389 : 539 : if (pblock == NULL)
8390 : 411 : gfc_start_block (&block);
8391 : : else
8392 : 128 : gfc_init_block (&block);
8393 : :
8394 : 539 : if (clausesa == NULL)
8395 : : {
8396 : 126 : clausesa = clausesa_buf;
8397 : 126 : gfc_split_omp_clauses (code, clausesa);
8398 : 126 : free_clausesa = true;
8399 : : }
8400 : 539 : if (flag_openmp)
8401 : 534 : omp_do_clauses
8402 : 534 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
8403 : 667 : body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
8404 : : &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
8405 : 539 : if (pblock == NULL)
8406 : : {
8407 : 411 : if (TREE_CODE (body) != BIND_EXPR)
8408 : 411 : body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
8409 : : else
8410 : 0 : poplevel (0, 0);
8411 : : }
8412 : 128 : else if (TREE_CODE (body) != BIND_EXPR)
8413 : 128 : body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
8414 : 539 : if (flag_openmp)
8415 : : {
8416 : 534 : stmt = make_node (OMP_FOR);
8417 : 534 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8418 : 534 : TREE_TYPE (stmt) = void_type_node;
8419 : 534 : OMP_FOR_BODY (stmt) = body;
8420 : 534 : OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
8421 : : }
8422 : : else
8423 : : stmt = body;
8424 : 539 : gfc_add_expr_to_block (&block, stmt);
8425 : 539 : if (free_clausesa)
8426 : 126 : gfc_free_split_omp_clauses (code, clausesa);
8427 : 539 : return gfc_finish_block (&block);
8428 : : }
8429 : :
8430 : : static tree
8431 : 1313 : gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock,
8432 : : gfc_omp_clauses *clausesa)
8433 : : {
8434 : 1313 : stmtblock_t block, *new_pblock = pblock;
8435 : 1313 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8436 : 1313 : tree stmt, omp_clauses = NULL_TREE;
8437 : 1313 : bool free_clausesa = false;
8438 : :
8439 : 1313 : if (pblock == NULL)
8440 : 1105 : gfc_start_block (&block);
8441 : : else
8442 : 208 : gfc_init_block (&block);
8443 : :
8444 : 1313 : if (clausesa == NULL)
8445 : : {
8446 : 1105 : clausesa = clausesa_buf;
8447 : 1105 : gfc_split_omp_clauses (code, clausesa);
8448 : 1105 : free_clausesa = true;
8449 : : }
8450 : 1313 : omp_clauses
8451 : 1313 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8452 : : code->loc);
8453 : 1313 : if (pblock == NULL)
8454 : : {
8455 : 1105 : if (!clausesa[GFC_OMP_SPLIT_DO].ordered
8456 : 1096 : && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
8457 : : new_pblock = █
8458 : : else
8459 : 65 : pushlevel ();
8460 : : }
8461 : 2591 : stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO,
8462 : : new_pblock, &clausesa[GFC_OMP_SPLIT_DO],
8463 : : omp_clauses);
8464 : 1313 : if (pblock == NULL)
8465 : : {
8466 : 1105 : if (TREE_CODE (stmt) != BIND_EXPR)
8467 : 1089 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8468 : : else
8469 : 16 : poplevel (0, 0);
8470 : : }
8471 : 208 : else if (TREE_CODE (stmt) != BIND_EXPR)
8472 : 208 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8473 : 1313 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8474 : : void_type_node, stmt, omp_clauses);
8475 : 1313 : OMP_PARALLEL_COMBINED (stmt) = 1;
8476 : 1313 : gfc_add_expr_to_block (&block, stmt);
8477 : 1313 : if (free_clausesa)
8478 : 1105 : gfc_free_split_omp_clauses (code, clausesa);
8479 : 1313 : return gfc_finish_block (&block);
8480 : : }
8481 : :
8482 : : static tree
8483 : 413 : gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
8484 : : gfc_omp_clauses *clausesa)
8485 : : {
8486 : 413 : stmtblock_t block;
8487 : 413 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8488 : 413 : tree stmt, omp_clauses = NULL_TREE;
8489 : 413 : bool free_clausesa = false;
8490 : :
8491 : 413 : if (pblock == NULL)
8492 : 285 : gfc_start_block (&block);
8493 : : else
8494 : 128 : gfc_init_block (&block);
8495 : :
8496 : 413 : if (clausesa == NULL)
8497 : : {
8498 : 285 : clausesa = clausesa_buf;
8499 : 285 : gfc_split_omp_clauses (code, clausesa);
8500 : 285 : free_clausesa = true;
8501 : : }
8502 : 413 : if (flag_openmp)
8503 : 410 : omp_clauses
8504 : 410 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8505 : : code->loc);
8506 : 413 : if (pblock == NULL)
8507 : 285 : pushlevel ();
8508 : 413 : stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
8509 : 413 : if (pblock == NULL)
8510 : : {
8511 : 285 : if (TREE_CODE (stmt) != BIND_EXPR)
8512 : 214 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8513 : : else
8514 : 71 : poplevel (0, 0);
8515 : : }
8516 : 128 : else if (TREE_CODE (stmt) != BIND_EXPR)
8517 : 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8518 : 413 : if (flag_openmp)
8519 : : {
8520 : 410 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8521 : : void_type_node, stmt, omp_clauses);
8522 : 410 : OMP_PARALLEL_COMBINED (stmt) = 1;
8523 : : }
8524 : 413 : gfc_add_expr_to_block (&block, stmt);
8525 : 413 : if (free_clausesa)
8526 : 285 : gfc_free_split_omp_clauses (code, clausesa);
8527 : 413 : return gfc_finish_block (&block);
8528 : : }
8529 : :
8530 : : static tree
8531 : 54 : gfc_trans_omp_parallel_sections (gfc_code *code)
8532 : : {
8533 : 54 : stmtblock_t block;
8534 : 54 : gfc_omp_clauses section_clauses;
8535 : 54 : tree stmt, omp_clauses;
8536 : :
8537 : 54 : memset (§ion_clauses, 0, sizeof (section_clauses));
8538 : 54 : section_clauses.nowait = true;
8539 : :
8540 : 54 : gfc_start_block (&block);
8541 : 54 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8542 : : code->loc);
8543 : 54 : pushlevel ();
8544 : 54 : stmt = gfc_trans_omp_sections (code, §ion_clauses);
8545 : 54 : if (TREE_CODE (stmt) != BIND_EXPR)
8546 : 54 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8547 : : else
8548 : 0 : poplevel (0, 0);
8549 : 54 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8550 : : void_type_node, stmt, omp_clauses);
8551 : 54 : OMP_PARALLEL_COMBINED (stmt) = 1;
8552 : 54 : gfc_add_expr_to_block (&block, stmt);
8553 : 54 : return gfc_finish_block (&block);
8554 : : }
8555 : :
8556 : : static tree
8557 : 50 : gfc_trans_omp_parallel_workshare (gfc_code *code)
8558 : : {
8559 : 50 : stmtblock_t block;
8560 : 50 : gfc_omp_clauses workshare_clauses;
8561 : 50 : tree stmt, omp_clauses;
8562 : :
8563 : 50 : memset (&workshare_clauses, 0, sizeof (workshare_clauses));
8564 : 50 : workshare_clauses.nowait = true;
8565 : :
8566 : 50 : gfc_start_block (&block);
8567 : 50 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8568 : : code->loc);
8569 : 50 : pushlevel ();
8570 : 50 : stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
8571 : 50 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8572 : 50 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8573 : : void_type_node, stmt, omp_clauses);
8574 : 50 : OMP_PARALLEL_COMBINED (stmt) = 1;
8575 : 50 : gfc_add_expr_to_block (&block, stmt);
8576 : 50 : return gfc_finish_block (&block);
8577 : : }
8578 : :
8579 : : static tree
8580 : 53 : gfc_trans_omp_scope (gfc_code *code)
8581 : : {
8582 : 53 : stmtblock_t block;
8583 : 53 : tree body = gfc_trans_code (code->block->next);
8584 : 53 : if (IS_EMPTY_STMT (body))
8585 : : return body;
8586 : 51 : gfc_start_block (&block);
8587 : 51 : tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8588 : : code->loc);
8589 : 51 : tree stmt = make_node (OMP_SCOPE);
8590 : 51 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8591 : 51 : TREE_TYPE (stmt) = void_type_node;
8592 : 51 : OMP_SCOPE_BODY (stmt) = body;
8593 : 51 : OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
8594 : 51 : gfc_add_expr_to_block (&block, stmt);
8595 : 51 : return gfc_finish_block (&block);
8596 : : }
8597 : :
8598 : : static tree
8599 : 129 : gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
8600 : : {
8601 : 129 : stmtblock_t block, body;
8602 : 129 : tree omp_clauses, stmt;
8603 : 129 : bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
8604 : 129 : location_t loc = gfc_get_location (&code->loc);
8605 : :
8606 : 129 : gfc_start_block (&block);
8607 : :
8608 : 129 : omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8609 : :
8610 : 129 : gfc_init_block (&body);
8611 : 499 : for (code = code->block; code; code = code->block)
8612 : : {
8613 : : /* Last section is special because of lastprivate, so even if it
8614 : : is empty, chain it in. */
8615 : 370 : stmt = gfc_trans_omp_code (code->next,
8616 : 370 : has_lastprivate && code->block == NULL);
8617 : 370 : if (! IS_EMPTY_STMT (stmt))
8618 : : {
8619 : 280 : stmt = build1_v (OMP_SECTION, stmt);
8620 : 280 : gfc_add_expr_to_block (&body, stmt);
8621 : : }
8622 : : }
8623 : 129 : stmt = gfc_finish_block (&body);
8624 : :
8625 : 129 : stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses);
8626 : 129 : gfc_add_expr_to_block (&block, stmt);
8627 : :
8628 : 129 : return gfc_finish_block (&block);
8629 : : }
8630 : :
8631 : : static tree
8632 : 555 : gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
8633 : : {
8634 : 555 : stmtblock_t block;
8635 : 555 : gfc_start_block (&block);
8636 : 555 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8637 : 555 : tree stmt = gfc_trans_omp_code (code->block->next, true);
8638 : 555 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
8639 : : stmt, omp_clauses);
8640 : 555 : gfc_add_expr_to_block (&block, stmt);
8641 : 555 : return gfc_finish_block (&block);
8642 : : }
8643 : :
8644 : : static tree
8645 : 1121 : gfc_trans_omp_task (gfc_code *code)
8646 : : {
8647 : 1121 : stmtblock_t block;
8648 : 1121 : tree stmt, omp_clauses;
8649 : :
8650 : 1121 : gfc_start_block (&block);
8651 : 1121 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8652 : : code->loc);
8653 : 1121 : pushlevel ();
8654 : 1121 : stmt = gfc_trans_omp_code (code->block->next, true);
8655 : 1121 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8656 : 1121 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node,
8657 : : stmt, omp_clauses);
8658 : 1121 : gfc_add_expr_to_block (&block, stmt);
8659 : 1121 : return gfc_finish_block (&block);
8660 : : }
8661 : :
8662 : : static tree
8663 : 181 : gfc_trans_omp_taskgroup (gfc_code *code)
8664 : : {
8665 : 181 : stmtblock_t block;
8666 : 181 : gfc_start_block (&block);
8667 : 181 : tree body = gfc_trans_code (code->block->next);
8668 : 181 : tree stmt = make_node (OMP_TASKGROUP);
8669 : 181 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8670 : 181 : TREE_TYPE (stmt) = void_type_node;
8671 : 181 : OMP_TASKGROUP_BODY (stmt) = body;
8672 : 181 : OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
8673 : : code->ext.omp_clauses,
8674 : : code->loc);
8675 : 181 : gfc_add_expr_to_block (&block, stmt);
8676 : 181 : return gfc_finish_block (&block);
8677 : : }
8678 : :
8679 : : static tree
8680 : 145 : gfc_trans_omp_taskwait (gfc_code *code)
8681 : : {
8682 : 145 : if (!code->ext.omp_clauses)
8683 : : {
8684 : 132 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
8685 : 132 : return build_call_expr_loc (input_location, decl, 0);
8686 : : }
8687 : 13 : stmtblock_t block;
8688 : 13 : gfc_start_block (&block);
8689 : 13 : tree stmt = make_node (OMP_TASK);
8690 : 13 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8691 : 13 : TREE_TYPE (stmt) = void_type_node;
8692 : 13 : OMP_TASK_BODY (stmt) = NULL_TREE;
8693 : 13 : OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
8694 : : code->ext.omp_clauses,
8695 : : code->loc);
8696 : 13 : gfc_add_expr_to_block (&block, stmt);
8697 : 13 : return gfc_finish_block (&block);
8698 : : }
8699 : :
8700 : : static tree
8701 : 8 : gfc_trans_omp_taskyield (void)
8702 : : {
8703 : 8 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
8704 : 8 : return build_call_expr_loc (input_location, decl, 0);
8705 : : }
8706 : :
8707 : : static tree
8708 : 341 : gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
8709 : : {
8710 : 341 : stmtblock_t block;
8711 : 341 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8712 : 341 : tree stmt, omp_clauses = NULL_TREE;
8713 : 341 : bool free_clausesa = false;
8714 : :
8715 : 341 : gfc_start_block (&block);
8716 : 341 : if (clausesa == NULL)
8717 : : {
8718 : 113 : clausesa = clausesa_buf;
8719 : 113 : gfc_split_omp_clauses (code, clausesa);
8720 : 113 : free_clausesa = true;
8721 : : }
8722 : 341 : if (flag_openmp)
8723 : 341 : omp_clauses
8724 : 341 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
8725 : : code->loc);
8726 : 341 : switch (code->op)
8727 : : {
8728 : 0 : case EXEC_OMP_DISTRIBUTE:
8729 : 0 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8730 : 0 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8731 : : /* This is handled in gfc_trans_omp_do. */
8732 : 0 : gcc_unreachable ();
8733 : 128 : break;
8734 : 128 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8735 : 128 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8736 : 128 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8737 : 128 : stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa);
8738 : 128 : if (TREE_CODE (stmt) != BIND_EXPR)
8739 : 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8740 : : else
8741 : 0 : poplevel (0, 0);
8742 : : break;
8743 : 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8744 : 113 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8745 : 113 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8746 : 113 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
8747 : 113 : if (TREE_CODE (stmt) != BIND_EXPR)
8748 : 113 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8749 : : else
8750 : 0 : poplevel (0, 0);
8751 : : break;
8752 : 100 : case EXEC_OMP_DISTRIBUTE_SIMD:
8753 : 100 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8754 : 100 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8755 : 100 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
8756 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
8757 : 100 : if (TREE_CODE (stmt) != BIND_EXPR)
8758 : 100 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8759 : : else
8760 : 0 : poplevel (0, 0);
8761 : : break;
8762 : 0 : default:
8763 : 0 : gcc_unreachable ();
8764 : : }
8765 : 341 : if (flag_openmp)
8766 : : {
8767 : 341 : tree distribute = make_node (OMP_DISTRIBUTE);
8768 : 341 : SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc));
8769 : 341 : TREE_TYPE (distribute) = void_type_node;
8770 : 341 : OMP_FOR_BODY (distribute) = stmt;
8771 : 341 : OMP_FOR_CLAUSES (distribute) = omp_clauses;
8772 : 341 : stmt = distribute;
8773 : : }
8774 : 341 : gfc_add_expr_to_block (&block, stmt);
8775 : 341 : if (free_clausesa)
8776 : 113 : gfc_free_split_omp_clauses (code, clausesa);
8777 : 341 : return gfc_finish_block (&block);
8778 : : }
8779 : :
8780 : : static tree
8781 : 468 : gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
8782 : : tree omp_clauses)
8783 : : {
8784 : 468 : stmtblock_t block;
8785 : 468 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8786 : 468 : tree stmt;
8787 : 468 : bool combined = true, free_clausesa = false;
8788 : :
8789 : 468 : gfc_start_block (&block);
8790 : 468 : if (clausesa == NULL)
8791 : : {
8792 : 269 : clausesa = clausesa_buf;
8793 : 269 : gfc_split_omp_clauses (code, clausesa);
8794 : 269 : free_clausesa = true;
8795 : : }
8796 : 468 : if (flag_openmp)
8797 : : {
8798 : 468 : omp_clauses
8799 : 468 : = chainon (omp_clauses,
8800 : : gfc_trans_omp_clauses (&block,
8801 : : &clausesa[GFC_OMP_SPLIT_TEAMS],
8802 : : code->loc));
8803 : 468 : pushlevel ();
8804 : : }
8805 : 468 : switch (code->op)
8806 : : {
8807 : 193 : case EXEC_OMP_TARGET_TEAMS:
8808 : 193 : case EXEC_OMP_TEAMS:
8809 : 193 : stmt = gfc_trans_omp_code (code->block->next, true);
8810 : 193 : combined = false;
8811 : 193 : break;
8812 : 28 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8813 : 28 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8814 : 28 : stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
8815 : : &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
8816 : : NULL);
8817 : 28 : break;
8818 : 19 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8819 : 19 : case EXEC_OMP_TEAMS_LOOP:
8820 : 19 : stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL,
8821 : : &clausesa[GFC_OMP_SPLIT_DO],
8822 : : NULL);
8823 : 19 : break;
8824 : 228 : default:
8825 : 228 : stmt = gfc_trans_omp_distribute (code, clausesa);
8826 : 228 : break;
8827 : : }
8828 : 468 : if (flag_openmp)
8829 : : {
8830 : 468 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8831 : 468 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS,
8832 : : void_type_node, stmt, omp_clauses);
8833 : 468 : if (combined)
8834 : 275 : OMP_TEAMS_COMBINED (stmt) = 1;
8835 : : }
8836 : 468 : gfc_add_expr_to_block (&block, stmt);
8837 : 468 : if (free_clausesa)
8838 : 269 : gfc_free_split_omp_clauses (code, clausesa);
8839 : 468 : return gfc_finish_block (&block);
8840 : : }
8841 : :
8842 : : static tree
8843 : 2010 : gfc_trans_omp_target (gfc_code *code)
8844 : : {
8845 : 2010 : stmtblock_t block;
8846 : 2010 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
8847 : 2010 : tree stmt, omp_clauses = NULL_TREE;
8848 : :
8849 : 2010 : gfc_start_block (&block);
8850 : 2010 : gfc_split_omp_clauses (code, clausesa);
8851 : 2010 : if (flag_openmp)
8852 : 2010 : omp_clauses
8853 : 2010 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
8854 : : code->loc);
8855 : 2010 : switch (code->op)
8856 : : {
8857 : 1670 : case EXEC_OMP_TARGET:
8858 : 1670 : pushlevel ();
8859 : 1670 : stmt = gfc_trans_omp_code (code->block->next, true);
8860 : 1670 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8861 : 1670 : break;
8862 : 20 : case EXEC_OMP_TARGET_PARALLEL:
8863 : 20 : {
8864 : 20 : stmtblock_t iblock;
8865 : :
8866 : 20 : pushlevel ();
8867 : 20 : gfc_start_block (&iblock);
8868 : 20 : tree inner_clauses
8869 : 20 : = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8870 : : code->loc);
8871 : 20 : stmt = gfc_trans_omp_code (code->block->next, true);
8872 : 20 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
8873 : : inner_clauses);
8874 : 20 : gfc_add_expr_to_block (&iblock, stmt);
8875 : 20 : stmt = gfc_finish_block (&iblock);
8876 : 20 : if (TREE_CODE (stmt) != BIND_EXPR)
8877 : 17 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8878 : : else
8879 : 3 : poplevel (0, 0);
8880 : : }
8881 : 20 : break;
8882 : 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
8883 : 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8884 : 80 : stmt = gfc_trans_omp_parallel_do (code,
8885 : : (code->op
8886 : : == EXEC_OMP_TARGET_PARALLEL_LOOP),
8887 : : &block, clausesa);
8888 : 80 : if (TREE_CODE (stmt) != BIND_EXPR)
8889 : 80 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8890 : : else
8891 : 0 : poplevel (0, 0);
8892 : : break;
8893 : 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8894 : 15 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
8895 : 15 : if (TREE_CODE (stmt) != BIND_EXPR)
8896 : 15 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8897 : : else
8898 : 0 : poplevel (0, 0);
8899 : : break;
8900 : 26 : case EXEC_OMP_TARGET_SIMD:
8901 : 26 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
8902 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
8903 : 26 : if (TREE_CODE (stmt) != BIND_EXPR)
8904 : 26 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8905 : : else
8906 : 0 : poplevel (0, 0);
8907 : : break;
8908 : 199 : default:
8909 : 199 : if (flag_openmp
8910 : 199 : && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
8911 : 149 : || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
8912 : : {
8913 : 51 : gfc_omp_clauses clausesb;
8914 : 51 : tree teams_clauses;
8915 : : /* For combined !$omp target teams, the num_teams and
8916 : : thread_limit clauses are evaluated before entering the
8917 : : target construct. */
8918 : 51 : memset (&clausesb, '\0', sizeof (clausesb));
8919 : 51 : clausesb.num_teams_lower
8920 : 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
8921 : 51 : clausesb.num_teams_upper
8922 : 51 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
8923 : 51 : clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
8924 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
8925 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
8926 : 51 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
8927 : 51 : teams_clauses
8928 : 51 : = gfc_trans_omp_clauses (&block, &clausesb, code->loc);
8929 : 51 : pushlevel ();
8930 : 51 : stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
8931 : 51 : }
8932 : : else
8933 : : {
8934 : 148 : pushlevel ();
8935 : 148 : stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
8936 : : }
8937 : 199 : if (TREE_CODE (stmt) != BIND_EXPR)
8938 : 198 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8939 : : else
8940 : 1 : poplevel (0, 0);
8941 : : break;
8942 : : }
8943 : 2010 : if (flag_openmp)
8944 : : {
8945 : 2010 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET,
8946 : : void_type_node, stmt, omp_clauses);
8947 : 2010 : if (code->op != EXEC_OMP_TARGET)
8948 : 340 : OMP_TARGET_COMBINED (stmt) = 1;
8949 : 2010 : cfun->has_omp_target = true;
8950 : : }
8951 : 2010 : gfc_add_expr_to_block (&block, stmt);
8952 : 2010 : gfc_free_split_omp_clauses (code, clausesa);
8953 : 2010 : return gfc_finish_block (&block);
8954 : : }
8955 : :
8956 : : static tree
8957 : 79 : gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
8958 : : {
8959 : 79 : stmtblock_t block;
8960 : 79 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
8961 : 79 : tree stmt, omp_clauses = NULL_TREE;
8962 : :
8963 : 79 : gfc_start_block (&block);
8964 : 79 : gfc_split_omp_clauses (code, clausesa);
8965 : 79 : if (flag_openmp)
8966 : 79 : omp_clauses
8967 : 79 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
8968 : : code->loc);
8969 : 79 : switch (op)
8970 : : {
8971 : 0 : case EXEC_OMP_TASKLOOP:
8972 : : /* This is handled in gfc_trans_omp_do. */
8973 : 0 : gcc_unreachable ();
8974 : 79 : break;
8975 : 79 : case EXEC_OMP_TASKLOOP_SIMD:
8976 : 79 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
8977 : : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
8978 : 79 : if (TREE_CODE (stmt) != BIND_EXPR)
8979 : 79 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8980 : : else
8981 : 0 : poplevel (0, 0);
8982 : 79 : break;
8983 : 0 : default:
8984 : 0 : gcc_unreachable ();
8985 : : }
8986 : 79 : if (flag_openmp)
8987 : : {
8988 : 79 : tree taskloop = make_node (OMP_TASKLOOP);
8989 : 79 : SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc));
8990 : 79 : TREE_TYPE (taskloop) = void_type_node;
8991 : 79 : OMP_FOR_BODY (taskloop) = stmt;
8992 : 79 : OMP_FOR_CLAUSES (taskloop) = omp_clauses;
8993 : 79 : stmt = taskloop;
8994 : : }
8995 : 79 : gfc_add_expr_to_block (&block, stmt);
8996 : 79 : gfc_free_split_omp_clauses (code, clausesa);
8997 : 79 : return gfc_finish_block (&block);
8998 : : }
8999 : :
9000 : : static tree
9001 : 84 : gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
9002 : : {
9003 : 84 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9004 : 84 : stmtblock_t block;
9005 : 84 : tree stmt;
9006 : :
9007 : 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9008 : 55 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9009 : 44 : gfc_split_omp_clauses (code, clausesa);
9010 : :
9011 : 84 : pushlevel ();
9012 : 84 : if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
9013 : 84 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
9014 : 48 : stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD);
9015 : : else
9016 : : {
9017 : 36 : gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
9018 : : || op == EXEC_OMP_MASTER_TASKLOOP);
9019 : 36 : stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL,
9020 : 36 : code->op != EXEC_OMP_MASTER_TASKLOOP
9021 : : ? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
9022 : : : code->ext.omp_clauses, NULL);
9023 : : }
9024 : 84 : if (TREE_CODE (stmt) != BIND_EXPR)
9025 : 55 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9026 : : else
9027 : 29 : poplevel (0, 0);
9028 : 84 : gfc_start_block (&block);
9029 : 84 : if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
9030 : : {
9031 : 34 : tree clauses = gfc_trans_omp_clauses (&block,
9032 : : &clausesa[GFC_OMP_SPLIT_MASKED],
9033 : : code->loc);
9034 : 34 : tree msk = make_node (OMP_MASKED);
9035 : 34 : SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc));
9036 : 34 : TREE_TYPE (msk) = void_type_node;
9037 : 34 : OMP_MASKED_BODY (msk) = stmt;
9038 : 34 : OMP_MASKED_CLAUSES (msk) = clauses;
9039 : 34 : OMP_MASKED_COMBINED (msk) = 1;
9040 : 34 : gfc_add_expr_to_block (&block, msk);
9041 : : }
9042 : : else
9043 : : {
9044 : 50 : gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
9045 : : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
9046 : 50 : stmt = build1_v (OMP_MASTER, stmt);
9047 : 50 : gfc_add_expr_to_block (&block, stmt);
9048 : : }
9049 : 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9050 : 55 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9051 : 44 : gfc_free_split_omp_clauses (code, clausesa);
9052 : 84 : return gfc_finish_block (&block);
9053 : : }
9054 : :
9055 : : static tree
9056 : 61 : gfc_trans_omp_parallel_master_masked (gfc_code *code)
9057 : : {
9058 : 61 : stmtblock_t block;
9059 : 61 : tree stmt, omp_clauses;
9060 : 61 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9061 : 61 : bool parallel_combined = false;
9062 : :
9063 : 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9064 : 50 : gfc_split_omp_clauses (code, clausesa);
9065 : :
9066 : 61 : gfc_start_block (&block);
9067 : 61 : omp_clauses = gfc_trans_omp_clauses (&block,
9068 : 61 : code->op == EXEC_OMP_PARALLEL_MASTER
9069 : : ? code->ext.omp_clauses
9070 : : : &clausesa[GFC_OMP_SPLIT_PARALLEL],
9071 : : code->loc);
9072 : 61 : pushlevel ();
9073 : 61 : if (code->op == EXEC_OMP_PARALLEL_MASTER)
9074 : 11 : stmt = gfc_trans_omp_master (code);
9075 : 50 : else if (code->op == EXEC_OMP_PARALLEL_MASKED)
9076 : 11 : stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]);
9077 : : else
9078 : : {
9079 : 39 : gfc_exec_op op;
9080 : 39 : switch (code->op)
9081 : : {
9082 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9083 : : op = EXEC_OMP_MASKED_TASKLOOP;
9084 : : break;
9085 : 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9086 : 8 : op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
9087 : 8 : break;
9088 : 10 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9089 : 10 : op = EXEC_OMP_MASTER_TASKLOOP;
9090 : 10 : break;
9091 : 14 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9092 : 14 : op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
9093 : 14 : break;
9094 : 0 : default:
9095 : 0 : gcc_unreachable ();
9096 : : }
9097 : 39 : stmt = gfc_trans_omp_master_masked_taskloop (code, op);
9098 : 39 : parallel_combined = true;
9099 : : }
9100 : 61 : if (TREE_CODE (stmt) != BIND_EXPR)
9101 : 48 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9102 : : else
9103 : 13 : poplevel (0, 0);
9104 : 61 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
9105 : : void_type_node, stmt, omp_clauses);
9106 : : /* masked does have just filter clause, but during gimplification
9107 : : isn't represented by a gimplification omp context, so for
9108 : : !$omp parallel masked don't set OMP_PARALLEL_COMBINED,
9109 : : so that
9110 : : !$omp parallel masked
9111 : : !$omp taskloop simd lastprivate (x)
9112 : : isn't confused with
9113 : : !$omp parallel masked taskloop simd lastprivate (x) */
9114 : 61 : if (parallel_combined)
9115 : 39 : OMP_PARALLEL_COMBINED (stmt) = 1;
9116 : 61 : gfc_add_expr_to_block (&block, stmt);
9117 : 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9118 : 50 : gfc_free_split_omp_clauses (code, clausesa);
9119 : 61 : return gfc_finish_block (&block);
9120 : : }
9121 : :
9122 : : static tree
9123 : 1388 : gfc_trans_omp_target_data (gfc_code *code)
9124 : : {
9125 : 1388 : stmtblock_t block;
9126 : 1388 : tree stmt, omp_clauses;
9127 : :
9128 : 1388 : gfc_start_block (&block);
9129 : 1388 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9130 : : code->loc);
9131 : 1388 : stmt = gfc_trans_omp_code (code->block->next, true);
9132 : 1388 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA,
9133 : : void_type_node, stmt, omp_clauses);
9134 : 1388 : gfc_add_expr_to_block (&block, stmt);
9135 : 1388 : return gfc_finish_block (&block);
9136 : : }
9137 : :
9138 : : static tree
9139 : 337 : gfc_trans_omp_target_enter_data (gfc_code *code)
9140 : : {
9141 : 337 : stmtblock_t block;
9142 : 337 : tree stmt, omp_clauses;
9143 : :
9144 : 337 : gfc_start_block (&block);
9145 : 337 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9146 : : code->loc);
9147 : 337 : stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
9148 : : omp_clauses);
9149 : 337 : gfc_add_expr_to_block (&block, stmt);
9150 : 337 : return gfc_finish_block (&block);
9151 : : }
9152 : :
9153 : : static tree
9154 : 275 : gfc_trans_omp_target_exit_data (gfc_code *code)
9155 : : {
9156 : 275 : stmtblock_t block;
9157 : 275 : tree stmt, omp_clauses;
9158 : :
9159 : 275 : gfc_start_block (&block);
9160 : 275 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9161 : : code->loc, false, false, code->op);
9162 : 275 : stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
9163 : : omp_clauses);
9164 : 275 : gfc_add_expr_to_block (&block, stmt);
9165 : 275 : return gfc_finish_block (&block);
9166 : : }
9167 : :
9168 : : static tree
9169 : 1697 : gfc_trans_omp_target_update (gfc_code *code)
9170 : : {
9171 : 1697 : stmtblock_t block;
9172 : 1697 : tree stmt, omp_clauses;
9173 : :
9174 : 1697 : gfc_start_block (&block);
9175 : 1697 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9176 : : code->loc);
9177 : 1697 : stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
9178 : : omp_clauses);
9179 : 1697 : gfc_add_expr_to_block (&block, stmt);
9180 : 1697 : return gfc_finish_block (&block);
9181 : : }
9182 : :
9183 : : static tree
9184 : 8 : gfc_trans_openmp_interop (gfc_code *code, gfc_omp_clauses *clauses)
9185 : : {
9186 : 8 : stmtblock_t block;
9187 : 8 : gfc_start_block (&block);
9188 : 8 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
9189 : 8 : tree stmt = build1_loc (input_location, OMP_INTEROP, void_type_node,
9190 : : omp_clauses);
9191 : 8 : gfc_add_expr_to_block (&block, stmt);
9192 : 8 : return gfc_finish_block (&block);
9193 : : }
9194 : :
9195 : : static tree
9196 : 85 : gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
9197 : : {
9198 : 85 : tree res, tmp, stmt;
9199 : 85 : stmtblock_t block, *pblock = NULL;
9200 : 85 : stmtblock_t singleblock;
9201 : 85 : int saved_ompws_flags;
9202 : 85 : bool singleblock_in_progress = false;
9203 : : /* True if previous gfc_code in workshare construct is not workshared. */
9204 : 85 : bool prev_singleunit;
9205 : 85 : location_t loc = gfc_get_location (&code->loc);
9206 : :
9207 : 85 : code = code->block->next;
9208 : :
9209 : 85 : pushlevel ();
9210 : :
9211 : 85 : gfc_start_block (&block);
9212 : 85 : pblock = █
9213 : :
9214 : 85 : ompws_flags = OMPWS_WORKSHARE_FLAG;
9215 : 85 : prev_singleunit = false;
9216 : :
9217 : : /* Translate statements one by one to trees until we reach
9218 : : the end of the workshare construct. Adjacent gfc_codes that
9219 : : are a single unit of work are clustered and encapsulated in a
9220 : : single OMP_SINGLE construct. */
9221 : 282 : for (; code; code = code->next)
9222 : : {
9223 : 197 : if (code->here != 0)
9224 : : {
9225 : 0 : res = gfc_trans_label_here (code);
9226 : 0 : gfc_add_expr_to_block (pblock, res);
9227 : : }
9228 : :
9229 : : /* No dependence analysis, use for clauses with wait.
9230 : : If this is the last gfc_code, use default omp_clauses. */
9231 : 197 : if (code->next == NULL && clauses->nowait)
9232 : 60 : ompws_flags |= OMPWS_NOWAIT;
9233 : :
9234 : : /* By default, every gfc_code is a single unit of work. */
9235 : 197 : ompws_flags |= OMPWS_CURR_SINGLEUNIT;
9236 : 197 : ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
9237 : :
9238 : 197 : switch (code->op)
9239 : : {
9240 : : case EXEC_NOP:
9241 : : res = NULL_TREE;
9242 : : break;
9243 : :
9244 : 125 : case EXEC_ASSIGN:
9245 : 125 : res = gfc_trans_assign (code);
9246 : 125 : break;
9247 : :
9248 : 0 : case EXEC_POINTER_ASSIGN:
9249 : 0 : res = gfc_trans_pointer_assign (code);
9250 : 0 : break;
9251 : :
9252 : 0 : case EXEC_INIT_ASSIGN:
9253 : 0 : res = gfc_trans_init_assign (code);
9254 : 0 : break;
9255 : :
9256 : 24 : case EXEC_FORALL:
9257 : 24 : res = gfc_trans_forall (code);
9258 : 24 : break;
9259 : :
9260 : 19 : case EXEC_WHERE:
9261 : 19 : res = gfc_trans_where (code);
9262 : 19 : break;
9263 : :
9264 : 7 : case EXEC_OMP_ATOMIC:
9265 : 7 : res = gfc_trans_omp_directive (code);
9266 : 7 : break;
9267 : :
9268 : 17 : case EXEC_OMP_PARALLEL:
9269 : 17 : case EXEC_OMP_PARALLEL_DO:
9270 : 17 : case EXEC_OMP_PARALLEL_MASTER:
9271 : 17 : case EXEC_OMP_PARALLEL_SECTIONS:
9272 : 17 : case EXEC_OMP_PARALLEL_WORKSHARE:
9273 : 17 : case EXEC_OMP_CRITICAL:
9274 : 17 : saved_ompws_flags = ompws_flags;
9275 : 17 : ompws_flags = 0;
9276 : 17 : res = gfc_trans_omp_directive (code);
9277 : 17 : ompws_flags = saved_ompws_flags;
9278 : 17 : break;
9279 : :
9280 : 5 : case EXEC_BLOCK:
9281 : 5 : res = gfc_trans_block_construct (code);
9282 : 5 : break;
9283 : :
9284 : 0 : default:
9285 : 0 : gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
9286 : : }
9287 : :
9288 : 197 : input_location = gfc_get_location (&code->loc);
9289 : :
9290 : 197 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
9291 : : {
9292 : 197 : if (prev_singleunit)
9293 : : {
9294 : 72 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9295 : : /* Add current gfc_code to single block. */
9296 : 44 : gfc_add_expr_to_block (&singleblock, res);
9297 : : else
9298 : : {
9299 : : /* Finish single block and add it to pblock. */
9300 : 28 : tmp = gfc_finish_block (&singleblock);
9301 : 28 : tmp = build2_loc (loc, OMP_SINGLE,
9302 : : void_type_node, tmp, NULL_TREE);
9303 : 28 : gfc_add_expr_to_block (pblock, tmp);
9304 : : /* Add current gfc_code to pblock. */
9305 : 28 : gfc_add_expr_to_block (pblock, res);
9306 : 28 : singleblock_in_progress = false;
9307 : : }
9308 : : }
9309 : : else
9310 : : {
9311 : 125 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9312 : : {
9313 : : /* Start single block. */
9314 : 73 : gfc_init_block (&singleblock);
9315 : 73 : gfc_add_expr_to_block (&singleblock, res);
9316 : 73 : singleblock_in_progress = true;
9317 : 73 : loc = gfc_get_location (&code->loc);
9318 : : }
9319 : : else
9320 : : /* Add the new statement to the block. */
9321 : 52 : gfc_add_expr_to_block (pblock, res);
9322 : : }
9323 : 197 : prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
9324 : : }
9325 : : }
9326 : :
9327 : : /* Finish remaining SINGLE block, if we were in the middle of one. */
9328 : 85 : if (singleblock_in_progress)
9329 : : {
9330 : : /* Finish single block and add it to pblock. */
9331 : 45 : tmp = gfc_finish_block (&singleblock);
9332 : 45 : tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp,
9333 : 45 : clauses->nowait
9334 : 27 : ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
9335 : : : NULL_TREE);
9336 : 45 : gfc_add_expr_to_block (pblock, tmp);
9337 : : }
9338 : :
9339 : 85 : stmt = gfc_finish_block (pblock);
9340 : 85 : if (TREE_CODE (stmt) != BIND_EXPR)
9341 : : {
9342 : 65 : if (!IS_EMPTY_STMT (stmt))
9343 : : {
9344 : 65 : tree bindblock = poplevel (1, 0);
9345 : 65 : stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
9346 : : }
9347 : : else
9348 : 0 : poplevel (0, 0);
9349 : : }
9350 : : else
9351 : 20 : poplevel (0, 0);
9352 : :
9353 : 85 : if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
9354 : 0 : stmt = gfc_trans_omp_barrier ();
9355 : :
9356 : 85 : ompws_flags = 0;
9357 : 85 : return stmt;
9358 : : }
9359 : :
9360 : : tree
9361 : 76 : gfc_trans_oacc_declare (gfc_code *code)
9362 : : {
9363 : 76 : stmtblock_t block;
9364 : 76 : tree stmt, oacc_clauses;
9365 : 76 : enum tree_code construct_code;
9366 : :
9367 : 76 : construct_code = OACC_DATA;
9368 : :
9369 : 76 : gfc_start_block (&block);
9370 : :
9371 : 76 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
9372 : : code->loc, false, true);
9373 : 76 : stmt = gfc_trans_omp_code (code->block->next, true);
9374 : 76 : stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
9375 : : oacc_clauses);
9376 : 76 : gfc_add_expr_to_block (&block, stmt);
9377 : :
9378 : 76 : return gfc_finish_block (&block);
9379 : : }
9380 : :
9381 : : tree
9382 : 12036 : gfc_trans_oacc_directive (gfc_code *code)
9383 : : {
9384 : 12036 : switch (code->op)
9385 : : {
9386 : 1556 : case EXEC_OACC_PARALLEL_LOOP:
9387 : 1556 : case EXEC_OACC_KERNELS_LOOP:
9388 : 1556 : case EXEC_OACC_SERIAL_LOOP:
9389 : 1556 : return gfc_trans_oacc_combined_directive (code);
9390 : 4187 : case EXEC_OACC_PARALLEL:
9391 : 4187 : case EXEC_OACC_KERNELS:
9392 : 4187 : case EXEC_OACC_SERIAL:
9393 : 4187 : case EXEC_OACC_DATA:
9394 : 4187 : case EXEC_OACC_HOST_DATA:
9395 : 4187 : return gfc_trans_oacc_construct (code);
9396 : 3375 : case EXEC_OACC_LOOP:
9397 : 3375 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9398 : 3375 : NULL);
9399 : 2126 : case EXEC_OACC_UPDATE:
9400 : 2126 : case EXEC_OACC_CACHE:
9401 : 2126 : case EXEC_OACC_ENTER_DATA:
9402 : 2126 : case EXEC_OACC_EXIT_DATA:
9403 : 2126 : return gfc_trans_oacc_executable_directive (code);
9404 : 173 : case EXEC_OACC_WAIT:
9405 : 173 : return gfc_trans_oacc_wait_directive (code);
9406 : 543 : case EXEC_OACC_ATOMIC:
9407 : 543 : return gfc_trans_omp_atomic (code);
9408 : 76 : case EXEC_OACC_DECLARE:
9409 : 76 : return gfc_trans_oacc_declare (code);
9410 : 0 : default:
9411 : 0 : gcc_unreachable ();
9412 : : }
9413 : : }
9414 : :
9415 : : tree
9416 : 18754 : gfc_trans_omp_directive (gfc_code *code)
9417 : : {
9418 : 18754 : switch (code->op)
9419 : : {
9420 : 34 : case EXEC_OMP_ALLOCATE:
9421 : 34 : case EXEC_OMP_ALLOCATORS:
9422 : 34 : return gfc_trans_omp_allocators (code);
9423 : 10 : case EXEC_OMP_ASSUME:
9424 : 10 : return gfc_trans_omp_assume (code);
9425 : 2053 : case EXEC_OMP_ATOMIC:
9426 : 2053 : return gfc_trans_omp_atomic (code);
9427 : 603 : case EXEC_OMP_BARRIER:
9428 : 603 : return gfc_trans_omp_barrier ();
9429 : 310 : case EXEC_OMP_CANCEL:
9430 : 310 : return gfc_trans_omp_cancel (code);
9431 : 170 : case EXEC_OMP_CANCELLATION_POINT:
9432 : 170 : return gfc_trans_omp_cancellation_point (code);
9433 : 143 : case EXEC_OMP_CRITICAL:
9434 : 143 : return gfc_trans_omp_critical (code);
9435 : 108 : case EXEC_OMP_DEPOBJ:
9436 : 108 : return gfc_trans_omp_depobj (code);
9437 : 2455 : case EXEC_OMP_DISTRIBUTE:
9438 : 2455 : case EXEC_OMP_DO:
9439 : 2455 : case EXEC_OMP_LOOP:
9440 : 2455 : case EXEC_OMP_SIMD:
9441 : 2455 : case EXEC_OMP_TASKLOOP:
9442 : 2455 : case EXEC_OMP_TILE:
9443 : 2455 : case EXEC_OMP_UNROLL:
9444 : 2455 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9445 : 2455 : NULL);
9446 : 128 : case EXEC_OMP_DISPATCH:
9447 : 128 : return gfc_trans_omp_dispatch (code);
9448 : 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9449 : 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9450 : 113 : case EXEC_OMP_DISTRIBUTE_SIMD:
9451 : 113 : return gfc_trans_omp_distribute (code, NULL);
9452 : 126 : case EXEC_OMP_DO_SIMD:
9453 : 126 : return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
9454 : 29 : case EXEC_OMP_ERROR:
9455 : 29 : return gfc_trans_omp_error (code);
9456 : 70 : case EXEC_OMP_FLUSH:
9457 : 70 : return gfc_trans_omp_flush (code);
9458 : 38 : case EXEC_OMP_MASKED:
9459 : 38 : return gfc_trans_omp_masked (code, NULL);
9460 : 104 : case EXEC_OMP_MASTER:
9461 : 104 : return gfc_trans_omp_master (code);
9462 : 45 : case EXEC_OMP_MASKED_TASKLOOP:
9463 : 45 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9464 : 45 : case EXEC_OMP_MASTER_TASKLOOP:
9465 : 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9466 : 45 : return gfc_trans_omp_master_masked_taskloop (code, code->op);
9467 : 88 : case EXEC_OMP_METADIRECTIVE:
9468 : 88 : return gfc_trans_omp_metadirective (code);
9469 : 519 : case EXEC_OMP_ORDERED:
9470 : 519 : return gfc_trans_omp_ordered (code);
9471 : 1865 : case EXEC_OMP_PARALLEL:
9472 : 1865 : return gfc_trans_omp_parallel (code);
9473 : 1081 : case EXEC_OMP_PARALLEL_DO:
9474 : 1081 : return gfc_trans_omp_parallel_do (code, false, NULL, NULL);
9475 : 24 : case EXEC_OMP_PARALLEL_LOOP:
9476 : 24 : return gfc_trans_omp_parallel_do (code, true, NULL, NULL);
9477 : 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
9478 : 285 : return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
9479 : 61 : case EXEC_OMP_PARALLEL_MASKED:
9480 : 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9481 : 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9482 : 61 : case EXEC_OMP_PARALLEL_MASTER:
9483 : 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9484 : 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9485 : 61 : return gfc_trans_omp_parallel_master_masked (code);
9486 : 54 : case EXEC_OMP_PARALLEL_SECTIONS:
9487 : 54 : return gfc_trans_omp_parallel_sections (code);
9488 : 50 : case EXEC_OMP_PARALLEL_WORKSHARE:
9489 : 50 : return gfc_trans_omp_parallel_workshare (code);
9490 : 53 : case EXEC_OMP_SCOPE:
9491 : 53 : return gfc_trans_omp_scope (code);
9492 : 75 : case EXEC_OMP_SECTIONS:
9493 : 75 : return gfc_trans_omp_sections (code, code->ext.omp_clauses);
9494 : 555 : case EXEC_OMP_SINGLE:
9495 : 555 : return gfc_trans_omp_single (code, code->ext.omp_clauses);
9496 : 2010 : case EXEC_OMP_TARGET:
9497 : 2010 : case EXEC_OMP_TARGET_PARALLEL:
9498 : 2010 : case EXEC_OMP_TARGET_PARALLEL_DO:
9499 : 2010 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9500 : 2010 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9501 : 2010 : case EXEC_OMP_TARGET_SIMD:
9502 : 2010 : case EXEC_OMP_TARGET_TEAMS:
9503 : 2010 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9504 : 2010 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9505 : 2010 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9506 : 2010 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9507 : 2010 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9508 : 2010 : return gfc_trans_omp_target (code);
9509 : 1388 : case EXEC_OMP_TARGET_DATA:
9510 : 1388 : return gfc_trans_omp_target_data (code);
9511 : 337 : case EXEC_OMP_TARGET_ENTER_DATA:
9512 : 337 : return gfc_trans_omp_target_enter_data (code);
9513 : 275 : case EXEC_OMP_TARGET_EXIT_DATA:
9514 : 275 : return gfc_trans_omp_target_exit_data (code);
9515 : 1697 : case EXEC_OMP_TARGET_UPDATE:
9516 : 1697 : return gfc_trans_omp_target_update (code);
9517 : 1121 : case EXEC_OMP_TASK:
9518 : 1121 : return gfc_trans_omp_task (code);
9519 : 181 : case EXEC_OMP_TASKGROUP:
9520 : 181 : return gfc_trans_omp_taskgroup (code);
9521 : 31 : case EXEC_OMP_TASKLOOP_SIMD:
9522 : 31 : return gfc_trans_omp_taskloop (code, code->op);
9523 : 145 : case EXEC_OMP_TASKWAIT:
9524 : 145 : return gfc_trans_omp_taskwait (code);
9525 : 8 : case EXEC_OMP_TASKYIELD:
9526 : 8 : return gfc_trans_omp_taskyield ();
9527 : 269 : case EXEC_OMP_TEAMS:
9528 : 269 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9529 : 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9530 : 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9531 : 269 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9532 : 269 : case EXEC_OMP_TEAMS_LOOP:
9533 : 269 : return gfc_trans_omp_teams (code, NULL, NULL_TREE);
9534 : 35 : case EXEC_OMP_WORKSHARE:
9535 : 35 : return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
9536 : 8 : case EXEC_OMP_INTEROP:
9537 : 8 : return gfc_trans_openmp_interop (code, code->ext.omp_clauses);
9538 : 0 : default:
9539 : 0 : gcc_unreachable ();
9540 : : }
9541 : : }
9542 : :
9543 : : void
9544 : 109 : gfc_trans_omp_declare_simd (gfc_namespace *ns)
9545 : : {
9546 : 109 : if (ns->entries)
9547 : : return;
9548 : :
9549 : 109 : gfc_omp_declare_simd *ods;
9550 : 262 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
9551 : : {
9552 : 153 : tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
9553 : 153 : tree fndecl = ns->proc_name->backend_decl;
9554 : 153 : if (c != NULL_TREE)
9555 : 103 : c = tree_cons (NULL_TREE, c, NULL_TREE);
9556 : 153 : c = build_tree_list (get_identifier ("omp declare simd"), c);
9557 : 153 : TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
9558 : 153 : DECL_ATTRIBUTES (fndecl) = c;
9559 : : }
9560 : : }
9561 : :
9562 : : /* Translate the context selector list GFC_SELECTORS, using WHERE as the
9563 : : locus for error messages. */
9564 : :
9565 : : static tree
9566 : 513 : gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where)
9567 : : {
9568 : 513 : tree set_selectors = NULL_TREE;
9569 : 513 : gfc_omp_set_selector *oss;
9570 : :
9571 : 1004 : for (oss = gfc_selectors; oss; oss = oss->next)
9572 : : {
9573 : 491 : tree selectors = NULL_TREE;
9574 : 491 : gfc_omp_selector *os;
9575 : 491 : enum omp_tss_code set = oss->code;
9576 : 491 : gcc_assert (set != OMP_TRAIT_SET_INVALID);
9577 : :
9578 : 1107 : for (os = oss->trait_selectors; os; os = os->next)
9579 : : {
9580 : 616 : tree scoreval = NULL_TREE;
9581 : 616 : tree properties = NULL_TREE;
9582 : 616 : gfc_omp_trait_property *otp;
9583 : 616 : enum omp_ts_code sel = os->code;
9584 : :
9585 : : /* Per the spec, "Implementations can ignore specified
9586 : : selectors that are not those described in this section";
9587 : : however, we must record such selectors because they
9588 : : cause match failures. */
9589 : 616 : if (sel == OMP_TRAIT_INVALID)
9590 : : {
9591 : 1 : selectors = make_trait_selector (sel, NULL_TREE, NULL_TREE,
9592 : : selectors);
9593 : 1 : continue;
9594 : : }
9595 : :
9596 : 987 : for (otp = os->properties; otp; otp = otp->next)
9597 : : {
9598 : 372 : switch (otp->property_kind)
9599 : : {
9600 : 85 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
9601 : 85 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
9602 : 85 : {
9603 : 85 : tree expr = NULL_TREE;
9604 : 85 : gfc_se se;
9605 : 85 : gfc_init_se (&se, NULL);
9606 : 85 : gfc_conv_expr (&se, otp->expr);
9607 : 85 : expr = se.expr;
9608 : 85 : properties = make_trait_property (NULL_TREE, expr,
9609 : : properties);
9610 : : }
9611 : 85 : break;
9612 : 23 : case OMP_TRAIT_PROPERTY_ID:
9613 : 23 : properties
9614 : 23 : = make_trait_property (get_identifier (otp->name),
9615 : : NULL_TREE, properties);
9616 : 23 : break;
9617 : 250 : case OMP_TRAIT_PROPERTY_NAME_LIST:
9618 : 250 : {
9619 : 250 : tree prop = OMP_TP_NAMELIST_NODE;
9620 : 250 : tree value = NULL_TREE;
9621 : 250 : if (otp->is_name)
9622 : 165 : value = get_identifier (otp->name);
9623 : : else
9624 : 85 : value = gfc_conv_constant_to_tree (otp->expr);
9625 : :
9626 : 250 : properties = make_trait_property (prop, value,
9627 : : properties);
9628 : : }
9629 : 250 : break;
9630 : 14 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
9631 : 14 : properties = gfc_trans_omp_clauses (NULL, otp->clauses,
9632 : : where, true);
9633 : 14 : break;
9634 : 0 : default:
9635 : 0 : gcc_unreachable ();
9636 : : }
9637 : : }
9638 : :
9639 : 615 : if (os->score)
9640 : : {
9641 : 51 : gfc_se se;
9642 : 51 : gfc_init_se (&se, NULL);
9643 : 51 : gfc_conv_expr (&se, os->score);
9644 : 51 : scoreval = se.expr;
9645 : : }
9646 : :
9647 : 615 : selectors = make_trait_selector (sel, scoreval,
9648 : : properties, selectors);
9649 : : }
9650 : 491 : set_selectors = make_trait_set_selector (set, selectors, set_selectors);
9651 : : }
9652 : 513 : return set_selectors;
9653 : : }
9654 : :
9655 : : /* If 'ns' points to a formal namespace in an interface, ns->parent == NULL;
9656 : : hence, parent_ns is used instead. */
9657 : :
9658 : : void
9659 : 10107 : gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns)
9660 : : {
9661 : 10107 : tree base_fn_decl = ns->proc_name->backend_decl;
9662 : 10107 : gfc_namespace *search_ns = ns;
9663 : 10107 : gfc_omp_declare_variant *next;
9664 : :
9665 : 10107 : for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
9666 : 27416 : search_ns; odv = next)
9667 : : {
9668 : : /* Look in the parent namespace if there are no more directives in the
9669 : : current namespace. */
9670 : 17309 : if (!odv)
9671 : : {
9672 : 16924 : if (!search_ns->parent && search_ns == ns)
9673 : : search_ns = parent_ns;
9674 : : else
9675 : 11827 : search_ns = search_ns->parent;
9676 : 16924 : if (search_ns)
9677 : 6817 : next = search_ns->omp_declare_variant;
9678 : 16924 : continue;
9679 : : }
9680 : :
9681 : 385 : next = odv->next;
9682 : :
9683 : 385 : if (odv->error_p)
9684 : 17 : continue;
9685 : :
9686 : : /* Check directive the first time it is encountered. */
9687 : 368 : bool error_found = true;
9688 : :
9689 : 368 : if (odv->checked_p)
9690 : 43 : error_found = false;
9691 : 368 : if (odv->base_proc_symtree == NULL)
9692 : : {
9693 : 331 : if (!search_ns->proc_name->attr.function
9694 : 212 : && !search_ns->proc_name->attr.subroutine)
9695 : 1 : gfc_error ("The base name for %<declare variant%> must be "
9696 : : "specified at %L", &odv->where);
9697 : : else
9698 : : error_found = false;
9699 : : }
9700 : : else
9701 : : {
9702 : 37 : if (!search_ns->contained
9703 : 21 : && !odv->base_proc_symtree->n.sym->attr.use_assoc
9704 : 5 : && strcmp (odv->base_proc_symtree->name,
9705 : 5 : ns->proc_name->name))
9706 : 1 : gfc_error ("The base name at %L does not match the name of the "
9707 : : "current procedure", &odv->where);
9708 : 36 : else if (odv->base_proc_symtree->n.sym->attr.entry)
9709 : 1 : gfc_error ("The base name at %L must not be an entry name",
9710 : : &odv->where);
9711 : 35 : else if (odv->base_proc_symtree->n.sym->attr.generic)
9712 : 1 : gfc_error ("The base name at %L must not be a generic name",
9713 : : &odv->where);
9714 : 34 : else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
9715 : 1 : gfc_error ("The base name at %L must not be a procedure pointer",
9716 : : &odv->where);
9717 : 33 : else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
9718 : 1 : gfc_error ("The base procedure at %L must have an explicit "
9719 : : "interface", &odv->where);
9720 : : else
9721 : : error_found = false;
9722 : : }
9723 : :
9724 : 368 : odv->checked_p = true;
9725 : 368 : if (error_found)
9726 : : {
9727 : 6 : odv->error_p = true;
9728 : 6 : continue;
9729 : : }
9730 : :
9731 : : /* Ignore directives that do not apply to the current procedure. */
9732 : 362 : if ((odv->base_proc_symtree == NULL && search_ns != ns)
9733 : 336 : || (odv->base_proc_symtree != NULL
9734 : 32 : && !ns->proc_name->attr.use_assoc
9735 : 19 : && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))
9736 : 323 : || (odv->base_proc_symtree != NULL
9737 : 19 : && ns->proc_name->attr.use_assoc
9738 : 13 : && strcmp (odv->base_proc_symtree->n.sym->name,
9739 : : ns->proc_name->name)))
9740 : 44 : continue;
9741 : :
9742 : 318 : tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors,
9743 : : odv->where);
9744 : 318 : const char *variant_proc_name = odv->variant_proc_symtree->name;
9745 : 318 : gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
9746 : 318 : if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
9747 : : {
9748 : 39 : gfc_symtree *proc_st;
9749 : 39 : gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
9750 : 39 : variant_proc_sym = proc_st ? proc_st->n.sym : NULL;
9751 : : }
9752 : 39 : if (variant_proc_sym == NULL)
9753 : : {
9754 : 1 : gfc_error ("Cannot find symbol %qs at %L", variant_proc_name,
9755 : : &odv->where);
9756 : 1 : continue;
9757 : : }
9758 : 317 : set_selectors = omp_check_context_selector
9759 : 317 : (gfc_get_location (&odv->where), set_selectors,
9760 : : OMP_CTX_DECLARE_VARIANT);
9761 : 317 : if (set_selectors != error_mark_node)
9762 : : {
9763 : 297 : if (!variant_proc_sym->attr.implicit_type
9764 : 297 : && !variant_proc_sym->attr.subroutine
9765 : 89 : && !variant_proc_sym->attr.function)
9766 : : {
9767 : 0 : gfc_error ("variant %qs at %L is not a function or subroutine",
9768 : : variant_proc_name, &odv->where);
9769 : 0 : variant_proc_sym = NULL;
9770 : : }
9771 : 297 : else if (variant_proc_sym == ns->proc_name)
9772 : : {
9773 : 1 : gfc_error ("variant %qs at %L is the same as base function",
9774 : : variant_proc_name, &odv->where);
9775 : 1 : variant_proc_sym = NULL;
9776 : : }
9777 : 296 : else if (omp_get_context_selector (set_selectors,
9778 : : OMP_TRAIT_SET_CONSTRUCT,
9779 : : OMP_TRAIT_CONSTRUCT_SIMD)
9780 : : == NULL_TREE)
9781 : : {
9782 : 282 : char err[256];
9783 : 282 : gfc_formal_arglist *last_arg = NULL, *extra_arg = NULL;
9784 : 282 : int nappend_args = 0;
9785 : 282 : if (odv->append_args_list)
9786 : : {
9787 : 26 : gfc_formal_arglist *arg;
9788 : 26 : int nargs = 0;
9789 : 26 : for (arg = gfc_sym_get_dummy_args (ns->proc_name);
9790 : 56 : arg; arg = arg->next)
9791 : 30 : nargs++;
9792 : :
9793 : 26 : last_arg = gfc_sym_get_dummy_args (variant_proc_sym);
9794 : 33 : for (int i = 1 ; i < nargs && last_arg; i++)
9795 : 7 : last_arg = last_arg->next;
9796 : 26 : if (nargs == 0)
9797 : : {
9798 : 3 : extra_arg = last_arg;
9799 : 3 : last_arg = NULL;
9800 : 3 : variant_proc_sym->formal = NULL;
9801 : : }
9802 : 23 : else if (last_arg)
9803 : : {
9804 : 23 : extra_arg = last_arg->next;
9805 : 23 : last_arg->next = NULL;
9806 : : }
9807 : 76 : for (gfc_omp_namelist *n = odv->append_args_list; n != NULL;
9808 : 50 : n = n->next)
9809 : 50 : nappend_args++;
9810 : : }
9811 : 282 : if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
9812 : : variant_proc_sym->name, 0, 1,
9813 : : err, sizeof (err), NULL, NULL))
9814 : : {
9815 : 2 : gfc_error ("variant %qs and base %qs at %L have "
9816 : : "incompatible types: %s",
9817 : 2 : variant_proc_name, ns->proc_name->name,
9818 : : &odv->where, err);
9819 : 2 : if (nappend_args)
9820 : 0 : inform (gfc_get_location (&odv->append_args_list->where),
9821 : : "%<append_args%> clause implies that %qs has %d "
9822 : : "dummy arguments of integer type with "
9823 : : "%<omp_interop_kind%> kind", variant_proc_name,
9824 : : nappend_args);
9825 : : variant_proc_sym = NULL;
9826 : : }
9827 : 282 : if (last_arg)
9828 : 23 : last_arg->next = extra_arg;
9829 : 259 : else if (extra_arg)
9830 : 3 : variant_proc_sym->formal = extra_arg;
9831 : 26 : locus *loc = (odv->append_args_list
9832 : 282 : ? &odv->append_args_list->where : &odv->where);
9833 : 282 : int nextra_arg = 0;
9834 : 335 : for (; extra_arg; extra_arg = extra_arg->next)
9835 : : {
9836 : 53 : nextra_arg++;
9837 : 53 : if (!variant_proc_sym)
9838 : 8 : continue;
9839 : 45 : if (extra_arg->sym->ts.type != BT_INTEGER
9840 : 43 : || extra_arg->sym->ts.kind != gfc_index_integer_kind
9841 : 42 : || extra_arg->sym->attr.dimension
9842 : 40 : || extra_arg->sym->attr.codimension
9843 : 39 : || extra_arg->sym->attr.pointer
9844 : 38 : || extra_arg->sym->attr.allocatable
9845 : 37 : || extra_arg->sym->attr.proc_pointer)
9846 : : {
9847 : 8 : gfc_error ("%qs at %L must be a nonpointer, "
9848 : : "nonallocatable scalar integer dummy argument "
9849 : : "of %<omp_interop_kind%> kind as it utilized "
9850 : : "with the %<append_args%> clause at %L",
9851 : : extra_arg->sym->name,
9852 : : &extra_arg->sym->declared_at, loc);
9853 : 8 : variant_proc_sym = NULL;
9854 : : }
9855 : 45 : if (extra_arg->sym->attr.optional)
9856 : : {
9857 : 2 : gfc_error ("%qs at %L with OPTIONAL attribute "
9858 : : "not support when utilized with the "
9859 : : "%<append_args%> clause at %L",
9860 : : extra_arg->sym->name,
9861 : : &extra_arg->sym->declared_at, loc);
9862 : 2 : variant_proc_sym = NULL;
9863 : : }
9864 : : }
9865 : 282 : if (variant_proc_sym && nappend_args != nextra_arg)
9866 : : {
9867 : 1 : gfc_error ("%qs at %L has %d but requires %d "
9868 : : "%<omp_interop_kind%> kind dummy arguments as it "
9869 : : "is utilized with the %<append_args%> clause at "
9870 : : "%L", variant_proc_sym->name,
9871 : : &variant_proc_sym->declared_at, nextra_arg,
9872 : : nappend_args, loc);
9873 : 1 : variant_proc_sym = NULL;
9874 : : }
9875 : : }
9876 : 251 : if ((odv->adjust_args_list != NULL || odv->append_args_list != NULL)
9877 : 322 : && omp_get_context_selector (set_selectors,
9878 : : OMP_TRAIT_SET_CONSTRUCT,
9879 : : OMP_TRAIT_CONSTRUCT_DISPATCH)
9880 : : == NULL_TREE)
9881 : : {
9882 : 6 : gfc_error ("the %qs clause can only be specified if "
9883 : : "the %<dispatch%> selector of the construct "
9884 : : "selector set appears in the %<match%> clause at %L",
9885 : 3 : odv->adjust_args_list ? "adjust_args" : "append_args",
9886 : : &odv->where);
9887 : 3 : variant_proc_sym = NULL;
9888 : : }
9889 : 297 : if (variant_proc_sym != NULL)
9890 : : {
9891 : 281 : gfc_set_sym_referenced (variant_proc_sym);
9892 : 281 : tree construct
9893 : 281 : = omp_get_context_selector_list (set_selectors,
9894 : : OMP_TRAIT_SET_CONSTRUCT);
9895 : 281 : omp_mark_declare_variant (gfc_get_location (&odv->where),
9896 : : gfc_get_symbol_decl (variant_proc_sym),
9897 : : construct);
9898 : 281 : if (omp_context_selector_matches (set_selectors,
9899 : : NULL_TREE, false))
9900 : : {
9901 : 202 : tree need_device_ptr_list = NULL_TREE;
9902 : 202 : tree need_device_addr_list = NULL_TREE;
9903 : 202 : tree append_args_tree = NULL_TREE;
9904 : 202 : tree id = get_identifier ("omp declare variant base");
9905 : 202 : tree variant = gfc_get_symbol_decl (variant_proc_sym);
9906 : 202 : DECL_ATTRIBUTES (base_fn_decl)
9907 : 202 : = tree_cons (id, build_tree_list (variant, set_selectors),
9908 : 202 : DECL_ATTRIBUTES (base_fn_decl));
9909 : 202 : int arg_idx_offset = 0;
9910 : 202 : if (gfc_return_by_reference (ns->proc_name))
9911 : : {
9912 : 2 : arg_idx_offset++;
9913 : 2 : if (ns->proc_name->ts.type == BT_CHARACTER)
9914 : 2 : arg_idx_offset++;
9915 : : }
9916 : 202 : int nargs = 0;
9917 : 202 : for (gfc_formal_arglist *arg
9918 : 202 : = gfc_sym_get_dummy_args (ns->proc_name);
9919 : 443 : arg; arg = arg->next)
9920 : 241 : nargs++;
9921 : 202 : if (odv->append_args_list)
9922 : : {
9923 : 14 : int append_arg_no = arg_idx_offset + nargs;
9924 : 14 : tree last_arg = NULL_TREE;
9925 : 14 : for (gfc_omp_namelist *n = odv->append_args_list;
9926 : 43 : n != NULL; n = n->next)
9927 : : {
9928 : 29 : tree pref = NULL_TREE;
9929 : 29 : if (n->u.init.len)
9930 : : {
9931 : 22 : pref = build_string (n->u.init.len,
9932 : 11 : n->u2.init_interop);
9933 : 11 : TREE_TYPE (pref) = build_array_type_nelts (
9934 : : unsigned_char_type_node,
9935 : 11 : n->u.init.len);
9936 : : }
9937 : : /* Save location, (target + target sync) and
9938 : : prefer_type list in a tree list. */
9939 : 29 : tree t = build_tree_list (n->u.init.target
9940 : : ? boolean_true_node
9941 : : : boolean_false_node,
9942 : 29 : n->u.init.targetsync
9943 : : ? boolean_true_node
9944 : : : boolean_false_node);
9945 : 29 : t = build1_loc (gfc_get_location (&n->where),
9946 : : NOP_EXPR, void_type_node, t);
9947 : 29 : t = build_tree_list (t, pref);
9948 : 29 : if (append_args_tree)
9949 : : {
9950 : 15 : TREE_CHAIN (last_arg) = t;
9951 : 15 : last_arg = t;
9952 : : }
9953 : : else
9954 : : append_args_tree = last_arg = t;
9955 : : }
9956 : : /* Store as 'purpose' = arg number to be used for inserting
9957 : : and 'value' = list of interop items. */
9958 : 14 : append_args_tree = build_tree_list (
9959 : : build_int_cst (integer_type_node,
9960 : 14 : append_arg_no),
9961 : : append_args_tree);
9962 : : }
9963 : 202 : vec<gfc_symbol *> adjust_args_list = vNULL;
9964 : 202 : for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
9965 : 312 : arg_list != NULL; arg_list = arg_list->next)
9966 : : {
9967 : 110 : int from, to;
9968 : 110 : if (arg_list->expr == NULL || arg_list->sym)
9969 : 204 : from = ((arg_list->u.adj_args.omp_num_args_minus
9970 : 94 : || arg_list->u.adj_args.omp_num_args_plus)
9971 : 94 : ? nargs : 1);
9972 : : else
9973 : : {
9974 : 16 : if (arg_list->u.adj_args.omp_num_args_plus)
9975 : 0 : mpz_add_ui (arg_list->expr->value.integer,
9976 : 0 : arg_list->expr->value.integer, nargs);
9977 : 16 : if (arg_list->u.adj_args.omp_num_args_minus)
9978 : 2 : mpz_ui_sub (arg_list->expr->value.integer, nargs,
9979 : 2 : arg_list->expr->value.integer);
9980 : 16 : if (mpz_sgn (arg_list->expr->value.integer) <= 0)
9981 : : {
9982 : 1 : gfc_warning (OPT_Wopenmp,
9983 : : "Expected positive argument index "
9984 : : "at %L", &arg_list->where);
9985 : 1 : from = 1;
9986 : : }
9987 : : else
9988 : 15 : from
9989 : 15 : = (mpz_fits_sint_p (arg_list->expr->value.integer)
9990 : 15 : ? mpz_get_si (arg_list->expr->value.integer)
9991 : : : INT_MAX);
9992 : 16 : if (from > nargs)
9993 : 1 : gfc_warning (OPT_Wopenmp,
9994 : : "Argument index at %L exceeds number "
9995 : : "of arguments %d", &arg_list->where,
9996 : : nargs);
9997 : : }
9998 : 110 : locus loc = arg_list->where;
9999 : 110 : if (!arg_list->u.adj_args.range_start)
10000 : : to = from;
10001 : : else
10002 : : {
10003 : 6 : loc = gfc_get_location_range (&arg_list->where, 0,
10004 : : &arg_list->where, 0,
10005 : 6 : &arg_list->next->where);
10006 : 6 : if (arg_list->next->expr == NULL)
10007 : : to = nargs;
10008 : : else
10009 : : {
10010 : 4 : if (arg_list->next->u.adj_args.omp_num_args_plus)
10011 : 0 : mpz_add_ui (arg_list->next->expr->value.integer,
10012 : 0 : arg_list->next->expr->value.integer,
10013 : : nargs);
10014 : 4 : if (arg_list->next->u.adj_args.omp_num_args_minus)
10015 : 2 : mpz_ui_sub (arg_list->next->expr->value.integer,
10016 : : nargs,
10017 : 2 : arg_list->next->expr->value.integer);
10018 : 4 : if (mpz_sgn (arg_list->next->expr->value.integer)
10019 : : <= 0)
10020 : : {
10021 : 0 : gfc_warning (OPT_Wopenmp,
10022 : : "Expected positive argument "
10023 : : "index at %L", &loc);
10024 : 0 : to = 0;
10025 : : }
10026 : : else
10027 : 4 : to = mpz_get_si (
10028 : 4 : arg_list->next->expr->value.integer);
10029 : : }
10030 : 6 : if (from > to && to != 0)
10031 : 1 : gfc_warning (OPT_Wopenmp,
10032 : : "Upper argument index smaller than "
10033 : : "lower one at %L", &loc);
10034 : 6 : if (to > nargs)
10035 : : to = nargs;
10036 : 6 : arg_list = arg_list->next;
10037 : : }
10038 : 110 : if (from > nargs)
10039 : 1 : continue;
10040 : : /* Change to zero based index. */
10041 : 109 : from--; to--;
10042 : 109 : gfc_formal_arglist *arg = ns->proc_name->formal;
10043 : 109 : if (!arg_list->sym && to >= from)
10044 : 35 : for (int idx = 0; idx < from; idx++)
10045 : 18 : arg = arg->next;
10046 : 223 : for (int idx = from; idx <= to; idx++)
10047 : : {
10048 : 114 : if (idx > from)
10049 : 6 : arg = arg->next;
10050 : 114 : if (arg_list->sym)
10051 : : {
10052 : 91 : for (arg = ns->proc_name->formal, idx = 0;
10053 : 201 : arg != NULL; arg = arg->next, idx++)
10054 : 200 : if (arg->sym == arg_list->sym)
10055 : : break;
10056 : 91 : if (!arg || !arg_list->sym->attr.dummy)
10057 : : {
10058 : 1 : gfc_error ("List item %qs at %L, declared at "
10059 : : "%L, is not a dummy argument",
10060 : : arg_list->sym->name, &loc,
10061 : : &arg_list->sym->declared_at);
10062 : 1 : continue;
10063 : : }
10064 : : }
10065 : 113 : if (arg_list->u.adj_args.need_ptr
10066 : 82 : && (arg->sym->ts.f90_type != BT_VOID
10067 : 80 : || !arg->sym->ts.u.derived->ts.is_iso_c
10068 : 80 : || (arg->sym->ts.u.derived->intmod_sym_id
10069 : : != ISOCBINDING_PTR)
10070 : 79 : || arg->sym->attr.dimension))
10071 : : {
10072 : 6 : gfc_error ("Argument %qs at %L to list item in "
10073 : : "%<need_device_ptr%> at %L must be a "
10074 : : "scalar of TYPE(C_PTR)",
10075 : : arg->sym->name,
10076 : : &arg->sym->declared_at, &loc);
10077 : 6 : if (!arg->sym->attr.value)
10078 : 6 : inform (gfc_get_location (&loc),
10079 : : "Consider using %<need_device_addr%> "
10080 : : "instead");
10081 : 6 : continue;
10082 : : }
10083 : 107 : if (arg_list->u.adj_args.need_addr
10084 : 11 : && arg->sym->attr.value)
10085 : : {
10086 : 1 : gfc_error ("Argument %qs at %L to list item in "
10087 : : "%<need_device_addr%> at %L must not "
10088 : : "have the VALUE attribute",
10089 : : arg->sym->name,
10090 : : &arg->sym->declared_at, &loc);
10091 : 1 : continue;
10092 : : }
10093 : 106 : if (adjust_args_list.contains (arg->sym))
10094 : : {
10095 : 7 : gfc_error ("%qs at %L is specified more than "
10096 : 7 : "once", arg->sym->name, &loc);
10097 : 7 : continue;
10098 : : }
10099 : 99 : adjust_args_list.safe_push (arg->sym);
10100 : :
10101 : 99 : if (arg_list->u.adj_args.need_addr)
10102 : : {
10103 : : /* TODO: Has to to support OPTIONAL and array
10104 : : descriptors; should check for CLASS, coarrays?
10105 : : Reject "abc" and 123 as actual arguments (in
10106 : : gimplify.cc or in the FE? Reject noncontiguous
10107 : : actuals? Cf. also PR C++/118859.
10108 : : Also check array-valued type(c_ptr). */
10109 : 7 : static bool warned = false;
10110 : 7 : if (!warned)
10111 : 1 : sorry_at (gfc_get_location (&loc),
10112 : : "%<need_device_addr%> not yet "
10113 : : "supported");
10114 : 7 : warned = true;
10115 : 7 : continue;
10116 : 7 : }
10117 : 92 : if (arg_list->u.adj_args.need_ptr
10118 : : || arg_list->u.adj_args.need_addr)
10119 : : {
10120 : : // Store 0-based argument index,
10121 : : // as in gimplify_call_expr
10122 : 74 : tree t
10123 : 74 : = build_tree_list (
10124 : : NULL_TREE,
10125 : : build_int_cst (integer_type_node,
10126 : 74 : idx + arg_idx_offset));
10127 : 74 : if (arg_list->u.adj_args.need_ptr)
10128 : 74 : need_device_ptr_list
10129 : 74 : = chainon (need_device_ptr_list, t);
10130 : : else
10131 : 0 : need_device_addr_list
10132 : 0 : = chainon (need_device_addr_list, t);
10133 : : }
10134 : : }
10135 : : }
10136 : 202 : tree t = NULL_TREE;
10137 : 202 : if (need_device_ptr_list
10138 : 202 : || need_device_addr_list
10139 : 166 : || append_args_tree)
10140 : : {
10141 : 50 : t = build_tree_list (need_device_ptr_list,
10142 : : need_device_addr_list),
10143 : 50 : TREE_CHAIN (t) = append_args_tree;
10144 : 50 : DECL_ATTRIBUTES (variant) = tree_cons (
10145 : : get_identifier ("omp declare variant variant args"), t,
10146 : 50 : DECL_ATTRIBUTES (variant));
10147 : : }
10148 : : }
10149 : : }
10150 : : }
10151 : : }
10152 : 10107 : }
10153 : :
10154 : : /* Add ptr for tracking as being allocated by GOMP_alloc. */
10155 : :
10156 : : tree
10157 : 29 : gfc_omp_call_add_alloc (tree ptr)
10158 : : {
10159 : 29 : static tree fn = NULL_TREE;
10160 : 29 : if (fn == NULL_TREE)
10161 : : {
10162 : 6 : fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
10163 : 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10164 : 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10165 : 6 : fn = build_type_attribute_variant (fn, att);
10166 : 6 : fn = build_fn_decl ("GOMP_add_alloc", fn);
10167 : : }
10168 : 29 : return build_call_expr_loc (input_location, fn, 1, ptr);
10169 : : }
10170 : :
10171 : : /* Generated function returns true when it was tracked via GOMP_add_alloc and
10172 : : removes it from the tracking. As called just before GOMP_free or omp_realloc
10173 : : the pointer is or might become invalid, thus, it is always removed. */
10174 : :
10175 : : tree
10176 : 47 : gfc_omp_call_is_alloc (tree ptr)
10177 : : {
10178 : 47 : static tree fn = NULL_TREE;
10179 : 47 : if (fn == NULL_TREE)
10180 : : {
10181 : 6 : fn = build_function_type_list (boolean_type_node, ptr_type_node,
10182 : : NULL_TREE);
10183 : 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10184 : 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10185 : 6 : fn = build_type_attribute_variant (fn, att);
10186 : 6 : fn = build_fn_decl ("GOMP_is_alloc", fn);
10187 : : }
10188 : 47 : return build_call_expr_loc (input_location, fn, 1, ptr);
10189 : : }
10190 : :
10191 : : tree
10192 : 88 : gfc_trans_omp_metadirective (gfc_code *code)
10193 : : {
10194 : 88 : gfc_omp_variant *variant = code->ext.omp_variants;
10195 : :
10196 : 88 : tree metadirective_tree = make_node (OMP_METADIRECTIVE);
10197 : 88 : SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc));
10198 : 88 : TREE_TYPE (metadirective_tree) = void_type_node;
10199 : 88 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree) = NULL_TREE;
10200 : :
10201 : 88 : tree tree_body = NULL_TREE;
10202 : :
10203 : 283 : while (variant)
10204 : : {
10205 : 195 : tree ctx = gfc_trans_omp_set_selector (variant->selectors,
10206 : : variant->where);
10207 : 195 : ctx = omp_check_context_selector (gfc_get_location (&variant->where),
10208 : : ctx, OMP_CTX_METADIRECTIVE);
10209 : 195 : if (ctx == error_mark_node)
10210 : : return error_mark_node;
10211 : :
10212 : : /* If the selector doesn't match, drop the whole variant. */
10213 : 195 : if (!omp_context_selector_matches (ctx, NULL_TREE, false))
10214 : : {
10215 : 23 : variant = variant->next;
10216 : 23 : continue;
10217 : : }
10218 : :
10219 : 172 : gfc_code *next_code = variant->code->next;
10220 : 172 : if (next_code && tree_body == NULL_TREE)
10221 : 18 : tree_body = gfc_trans_code (next_code);
10222 : :
10223 : 172 : if (next_code)
10224 : 20 : variant->code->next = NULL;
10225 : 172 : tree directive = gfc_trans_code (variant->code);
10226 : 172 : if (next_code)
10227 : 20 : variant->code->next = next_code;
10228 : :
10229 : 20 : tree body = next_code ? tree_body : NULL_TREE;
10230 : 172 : tree omp_variant = make_omp_metadirective_variant (ctx, directive, body);
10231 : 344 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree)
10232 : 172 : = chainon (OMP_METADIRECTIVE_VARIANTS (metadirective_tree),
10233 : : omp_variant);
10234 : 172 : variant = variant->next;
10235 : : }
10236 : :
10237 : : /* TODO: Resolve the metadirective here if possible. */
10238 : :
10239 : : return metadirective_tree;
10240 : : }
|
