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