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 46454 : gfc_omp_is_optional_argument (const_tree decl)
83 : {
84 : /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
85 30881 : return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl))
86 46454 : && 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 67065 : && 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 22695 : gfc_omp_check_optional_argument (tree decl, bool for_present_check)
103 : {
104 22695 : if (!for_present_check)
105 2176 : return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE;
106 :
107 20519 : 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 19902 : gfc_omp_array_data (tree decl, bool type_only)
161 : {
162 19902 : tree type = TREE_TYPE (decl);
163 :
164 19902 : if (POINTER_TYPE_P (type))
165 10249 : type = TREE_TYPE (type);
166 :
167 19902 : 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 (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 458723 : gfc_omp_privatize_by_reference (const_tree decl)
246 : {
247 458723 : tree type = TREE_TYPE (decl);
248 :
249 458723 : if (TREE_CODE (type) == REFERENCE_TYPE
250 458723 : && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
251 : return true;
252 :
253 436234 : if (TREE_CODE (type) == POINTER_TYPE
254 436234 : && gfc_omp_is_optional_argument (decl))
255 : return true;
256 :
257 427149 : if (TREE_CODE (type) == POINTER_TYPE)
258 : {
259 32979 : 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 32979 : if (GFC_DECL_GET_SCALAR_POINTER (decl)
267 31464 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
268 29110 : || GFC_DECL_CRAY_POINTEE (decl)
269 29104 : || GFC_DECL_ASSOCIATE_VAR_P (decl)
270 38672 : || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
271 : return false;
272 :
273 21030 : if (!DECL_ARTIFICIAL (decl)
274 21030 : && 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 13793 : if (DECL_LANG_SPECIFIC (decl)
280 13793 : && 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 8209 : 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 8209 : 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 8164 : if (DECL_ARTIFICIAL (decl)
307 1555 : && ! GFC_DECL_RESULT (decl)
308 9695 : && ! (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 6959 : if (GFC_DECL_CRAY_POINTEE (decl))
317 : return OMP_CLAUSE_DEFAULT_PRIVATE;
318 :
319 : /* Assumed-size arrays are predetermined shared. */
320 6923 : if (TREE_CODE (decl) == PARM_DECL
321 1860 : && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
322 692 : && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
323 7615 : && 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 6855 : if (TREE_CODE (decl) == PARM_DECL
333 1792 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
334 7616 : && 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 6839 : if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
342 : return OMP_CLAUSE_DEFAULT_SHARED;
343 :
344 6810 : 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 5010 : if (VAR_P (decl) && TREE_READONLY (decl)
353 6789 : && (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 4304 : gfc_omp_predetermined_mapping (tree decl)
365 : {
366 4304 : if (DECL_ARTIFICIAL (decl)
367 1036 : && ! GFC_DECL_RESULT (decl)
368 5334 : && ! (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 3323 : if (TREE_CODE (decl) == PARM_DECL
377 1815 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
378 3702 : && 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 3316 : && (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 122676 : gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok,
411 : bool shallow_alloc_only=false)
412 : {
413 122676 : tree field, ftype;
414 :
415 122676 : 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 122543 : if (!ptr_ok
425 97695 : && GFC_DESCRIPTOR_TYPE_P (type)
426 125855 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
427 2909 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
428 : return false;
429 :
430 122137 : if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
431 12838 : type = gfc_get_element_type (type);
432 :
433 122137 : if (TREE_CODE (type) != RECORD_TYPE)
434 : return false;
435 :
436 10309 : for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
437 : {
438 9146 : ftype = TREE_TYPE (field);
439 9146 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
440 : return true;
441 8578 : if (GFC_DESCRIPTOR_TYPE_P (ftype)
442 8578 : && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
443 : return true;
444 6105 : if (!shallow_alloc_only
445 6105 : && 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 66968 : gfc_is_polymorphic_nonptr (tree type)
491 : {
492 66968 : if (POINTER_TYPE_P (type))
493 3501 : type = TREE_TYPE (type);
494 66968 : 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 40822 : gfc_is_class_pointer_type (tree type)
501 : {
502 40822 : tree name;
503 40822 : const char *s;
504 :
505 40822 : if (POINTER_TYPE_P (type))
506 3223 : type = TREE_TYPE (type);
507 :
508 40822 : 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 4304 : gfc_omp_allocatable_p (tree decl)
547 : {
548 4304 : if (!DECL_P (decl))
549 : return false;
550 :
551 4304 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
552 : return true;
553 :
554 4079 : tree type = TREE_TYPE (decl);
555 4079 : if (gfc_omp_privatize_by_reference (decl))
556 1808 : type = TREE_TYPE (type);
557 :
558 4079 : if (GFC_DESCRIPTOR_TYPE_P (type)
559 4079 : && 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 14347 : gfc_omp_private_outer_ref (tree decl)
570 : {
571 14347 : tree type = TREE_TYPE (decl);
572 :
573 14347 : if (gfc_omp_privatize_by_reference (decl))
574 612 : type = TREE_TYPE (type);
575 :
576 14347 : if (GFC_DESCRIPTOR_TYPE_P (type)
577 14347 : && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
578 : return true;
579 :
580 14218 : if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
581 : return true;
582 :
583 14132 : 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 20133 : gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
820 : {
821 20133 : tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
822 20133 : stmtblock_t block, cond_block;
823 :
824 20133 : 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 20106 : case OMP_CLAUSE_PRIVATE:
832 20106 : case OMP_CLAUSE_LASTPRIVATE:
833 20106 : case OMP_CLAUSE_LINEAR:
834 20106 : case OMP_CLAUSE_REDUCTION:
835 20106 : case OMP_CLAUSE_IN_REDUCTION:
836 20106 : case OMP_CLAUSE_TASK_REDUCTION:
837 20106 : break;
838 0 : default:
839 0 : gcc_unreachable ();
840 : }
841 :
842 20106 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
843 265 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
844 20125 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
845 86 : || !POINTER_TYPE_P (type)))
846 : {
847 19774 : 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 9173 : gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
950 : {
951 9173 : tree type = TREE_TYPE (dest), ptr, size, call;
952 9173 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
953 9173 : tree orig_decl = OMP_CLAUSE_DECL (clause);
954 9173 : tree cond, then_b, else_b;
955 9173 : stmtblock_t block, cond_block;
956 :
957 9173 : gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
958 : || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
959 :
960 9173 : if (DECL_ARTIFICIAL (orig_decl)
961 6135 : && DECL_LANG_SPECIFIC (orig_decl)
962 9362 : && 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 9173 : if (DECL_P (orig_decl)
972 9173 : && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
973 9146 : || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
974 9120 : || gfc_is_class_pointer_type (decl_type)))
975 59 : return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
976 :
977 9114 : 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 9074 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1047 151 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1048 9104 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1049 77 : || !POINTER_TYPE_P (type)))
1050 : {
1051 8878 : 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 8858 : 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 6245 : gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
1145 : {
1146 6245 : tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
1147 6245 : tree cond, then_b, else_b;
1148 6245 : stmtblock_t block, cond_block, cond_block2, inner_block;
1149 :
1150 6245 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1151 236 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1152 12285 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1153 136 : || !POINTER_TYPE_P (type)))
1154 : {
1155 5904 : 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 5874 : 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 31774 : gfc_omp_clause_dtor (tree clause, tree decl)
1480 : {
1481 31774 : tree type = TREE_TYPE (decl), tem;
1482 31774 : tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
1483 31774 : tree orig_decl = OMP_CLAUSE_DECL (clause);
1484 :
1485 31774 : if (DECL_ARTIFICIAL (orig_decl)
1486 11838 : && DECL_LANG_SPECIFIC (orig_decl)
1487 32136 : && 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 31774 : if (DECL_P (orig_decl)
1496 31774 : && (GFC_DECL_ASSOCIATE_VAR_P (orig_decl)
1497 31747 : || GFC_DECL_GET_SCALAR_POINTER (orig_decl)
1498 31702 : || gfc_is_class_pointer_type (decl_type)))
1499 : return NULL_TREE;
1500 31690 : 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 31653 : if ((! GFC_DESCRIPTOR_TYPE_P (type)
1546 447 : || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
1547 31710 : && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
1548 187 : || !POINTER_TYPE_P (type)))
1549 : {
1550 31078 : 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 28821 : gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
1645 : {
1646 28821 : if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
1647 : return;
1648 :
1649 7157 : tree decl = OMP_CLAUSE_DECL (c);
1650 7157 : 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 7157 : 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 7528 : && 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 7156 : tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
1667 7156 : tree present = gfc_omp_check_optional_argument (decl, true);
1668 7156 : tree orig_decl = NULL_TREE;
1669 7156 : 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 7153 : 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 5422 : 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 5422 : tree type = TREE_TYPE (decl);
1897 5422 : if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type)))
1898 0 : type = TREE_TYPE (type);
1899 5422 : if (!openacc
1900 5422 : && orig_decl != NULL_TREE
1901 5422 : && 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 7153 : tree last = c;
1913 7153 : 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 7153 : 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 7153 : 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 7153 : 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 (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 (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 (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 42325 : gfc_omp_deep_map_kind_p (tree clause)
2376 : {
2377 42325 : switch (OMP_CLAUSE_CODE (clause))
2378 : {
2379 38741 : case OMP_CLAUSE_MAP:
2380 38741 : 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 38741 : 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 93924 : gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause)
2449 : {
2450 93924 : if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause))
2451 : return NULL_TREE;
2452 22422 : tree decl = OMP_CLAUSE_DECL (clause);
2453 22422 : if (OMP_CLAUSE_SIZE (clause) != NULL_TREE
2454 22352 : && DECL_P (OMP_CLAUSE_SIZE (clause))
2455 6578 : && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause))
2456 22721 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)))
2457 : /* Saved decl. */
2458 299 : decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause));
2459 22123 : 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 22422 : 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 22422 : if (DECL_P (decl)
2466 13560 : && DECL_LANG_SPECIFIC (decl)
2467 24590 : && 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 22422 : tree tmp = OMP_CLAUSE_CHAIN (clause);
2472 22422 : if (tmp != NULL_TREE
2473 16702 : && 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 22494 : && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl)
2478 : return NULL_TREE;
2479 22422 : if (DECL_P (decl)
2480 13560 : && DECL_LANG_SPECIFIC (decl)
2481 24545 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
2482 29 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2483 22422 : tree type = TREE_TYPE (decl);
2484 22422 : if (POINTER_TYPE_P (type))
2485 13445 : type = TREE_TYPE (type);
2486 22422 : if (POINTER_TYPE_P (type))
2487 140 : type = TREE_TYPE (type);
2488 22422 : tmp = decl;
2489 24184 : 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 22422 : if (!gfc_is_polymorphic_nonptr (type)
2492 22422 : && !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 45470 : gfc_omp_deep_mapping_p (const gimple *ctx, tree clause)
2504 : {
2505 45470 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2506 45470 : if (decl == NULL_TREE)
2507 45326 : return false;
2508 : return true;
2509 : }
2510 :
2511 : /* Handle gfc_omp_deep_mapping{,_cnt} */
2512 : static tree
2513 48430 : 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 48430 : tree num = NULL_TREE;
2519 48430 : location_t loc = OMP_CLAUSE_LOCATION (clause);
2520 48430 : tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
2521 48430 : bool poly_warned = false;
2522 48430 : 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 48002 : gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq)
2657 : {
2658 48002 : return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE,
2659 48002 : 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 4057 : gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
2688 : {
2689 4057 : tree type = TREE_TYPE (decl);
2690 4057 : if (TREE_CODE (type) == REFERENCE_TYPE)
2691 1351 : type = TREE_TYPE (type);
2692 4057 : 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 3485 : if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
2706 6290 : && TYPE_STRING_FLAG (type))
2707 : return false;
2708 3579 : if (INTEGRAL_TYPE_P (type)
2709 3579 : || SCALAR_FLOAT_TYPE_P (type)
2710 3579 : || COMPLEX_FLOAT_TYPE_P (type))
2711 2981 : 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 3955 : gfc_omp_scalar_target_p (tree decl)
2721 : {
2722 3955 : return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
2723 4056 : && 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 1695265 : gfc_omp_disregard_value_expr (tree decl, bool shared)
2734 : {
2735 1695265 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2736 1695265 : && 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 1692235 : 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 38376 : gfc_omp_private_debug_clause (tree decl, bool shared)
2767 : {
2768 38376 : if (GFC_DECL_CRAY_POINTEE (decl))
2769 : return true;
2770 :
2771 38340 : if (GFC_DECL_COMMON_OR_EQUIV (decl)
2772 38340 : && 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 21933 : gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
2790 : {
2791 21933 : if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
2792 : {
2793 3950 : int r;
2794 :
2795 3950 : gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
2796 9102 : for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
2797 : {
2798 5152 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
2799 5152 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
2800 5152 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
2801 : }
2802 3950 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
2803 3950 : omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
2804 : }
2805 21933 : }
2806 :
2807 :
2808 : static inline tree
2809 75921 : gfc_trans_add_clause (tree node, tree tail)
2810 : {
2811 75921 : OMP_CLAUSE_CHAIN (node) = tail;
2812 75921 : return node;
2813 : }
2814 :
2815 : static tree
2816 43430 : gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
2817 : {
2818 43430 : 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 43248 : tree t = gfc_get_symbol_decl (sym);
2844 43248 : tree parent_decl;
2845 43248 : int parent_flag;
2846 43248 : bool return_value;
2847 43248 : bool alternate_entry;
2848 43248 : bool entry_master;
2849 :
2850 43248 : return_value = sym->attr.function && sym->result == sym;
2851 167 : alternate_entry = sym->attr.function && sym->attr.entry
2852 43282 : && sym->result == sym;
2853 86496 : entry_master = sym->attr.result
2854 172 : && sym->ns->proc_name->attr.entry_master
2855 43260 : && !gfc_return_by_reference (sym->ns->proc_name);
2856 43248 : parent_decl = current_function_decl
2857 43248 : ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
2858 :
2859 43248 : if ((t == parent_decl && return_value)
2860 43241 : || (sym->ns && sym->ns->proc_name
2861 43241 : && sym->ns->proc_name->backend_decl == parent_decl
2862 2174 : && (alternate_entry || entry_master)))
2863 : parent_flag = 1;
2864 : else
2865 43239 : 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 43248 : 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 43151 : 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 43119 : 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 11622 : 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 30009 : for (; namelist != NULL; namelist = namelist->next)
2905 18387 : if ((namelist->sym->attr.referenced || declare_simd)
2906 18387 : && namelist->sym->attr.flavor != FL_PARAMETER)
2907 : {
2908 18382 : tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
2909 18382 : if (t != error_mark_node)
2910 : {
2911 18382 : tree node;
2912 18382 : node = build_omp_clause (input_location, code);
2913 18382 : OMP_CLAUSE_DECL (node) = t;
2914 18382 : list = gfc_trans_add_clause (node, list);
2915 :
2916 18382 : if (code == OMP_CLAUSE_LASTPRIVATE
2917 2788 : && namelist->u.lastprivate_conditional)
2918 82 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
2919 : }
2920 : }
2921 11622 : 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 668 : gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
2944 : {
2945 668 : gfc_symbol *sym = n->sym;
2946 668 : gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
2947 668 : gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
2948 668 : gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
2949 668 : gfc_symbol omp_var_copy[4];
2950 668 : gfc_expr *e1, *e2, *e3, *e4;
2951 668 : gfc_ref *ref;
2952 668 : tree decl, backend_decl, stmt, type, outer_decl;
2953 668 : locus old_loc = gfc_current_locus;
2954 668 : const char *iname;
2955 668 : bool t;
2956 668 : gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL;
2957 668 : gfc_namespace *old_ns = gfc_current_ns;
2958 :
2959 668 : if (gfc_current_ns->proc_name
2960 668 : && gfc_current_ns->proc_name->ns != gfc_current_ns)
2961 23 : gfc_current_ns = gfc_current_ns->proc_name->ns;
2962 :
2963 668 : decl = OMP_CLAUSE_DECL (c);
2964 668 : gfc_current_locus = where;
2965 668 : type = TREE_TYPE (decl);
2966 668 : outer_decl = create_tmp_var_raw (type);
2967 668 : if (TREE_CODE (decl) == PARM_DECL
2968 19 : && TREE_CODE (type) == REFERENCE_TYPE
2969 12 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
2970 680 : && 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 668 : memset (&init_val_sym, 0, sizeof (init_val_sym));
2978 668 : init_val_sym.ns = sym->ns;
2979 668 : init_val_sym.name = sym->name;
2980 668 : init_val_sym.ts = sym->ts;
2981 668 : init_val_sym.attr.referenced = 1;
2982 668 : init_val_sym.declared_at = where;
2983 668 : init_val_sym.attr.flavor = FL_VARIABLE;
2984 668 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
2985 266 : 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 668 : init_val_sym.backend_decl = backend_decl;
3002 :
3003 : /* Create a fake symbol for the outer array reference. */
3004 668 : outer_sym = *sym;
3005 668 : if (sym->as)
3006 408 : outer_sym.as = gfc_copy_array_spec (sym->as);
3007 668 : outer_sym.attr.dummy = 0;
3008 668 : outer_sym.attr.result = 0;
3009 668 : outer_sym.attr.flavor = FL_VARIABLE;
3010 668 : outer_sym.backend_decl = outer_decl;
3011 668 : 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 668 : symtree1 = gfc_new_symtree (&root1, sym->name);
3016 668 : symtree1->n.sym = sym;
3017 668 : gcc_assert (symtree1 == root1);
3018 :
3019 668 : symtree2 = gfc_new_symtree (&root2, sym->name);
3020 668 : symtree2->n.sym = &init_val_sym;
3021 668 : gcc_assert (symtree2 == root2);
3022 :
3023 668 : symtree3 = gfc_new_symtree (&root3, sym->name);
3024 668 : symtree3->n.sym = &outer_sym;
3025 668 : gcc_assert (symtree3 == root3);
3026 :
3027 668 : memset (omp_var_copy, 0, sizeof omp_var_copy);
3028 668 : 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 668 : e1 = gfc_get_expr ();
3045 668 : e1->expr_type = EXPR_VARIABLE;
3046 668 : e1->where = where;
3047 668 : e1->symtree = symtree1;
3048 668 : e1->ts = sym->ts;
3049 668 : if (sym->attr.dimension)
3050 : {
3051 408 : e1->ref = ref = gfc_get_ref ();
3052 408 : ref->type = REF_ARRAY;
3053 408 : ref->u.ar.where = where;
3054 408 : ref->u.ar.as = sym->as;
3055 408 : ref->u.ar.type = AR_FULL;
3056 408 : ref->u.ar.dimen = 0;
3057 : }
3058 668 : t = gfc_resolve_expr (e1);
3059 668 : gcc_assert (t);
3060 :
3061 668 : e2 = NULL;
3062 668 : if (backend_decl != NULL_TREE)
3063 : {
3064 281 : e2 = gfc_get_expr ();
3065 281 : e2->expr_type = EXPR_VARIABLE;
3066 281 : e2->where = where;
3067 281 : e2->symtree = symtree2;
3068 281 : e2->ts = sym->ts;
3069 281 : t = gfc_resolve_expr (e2);
3070 281 : 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 668 : 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 668 : e3 = gfc_copy_expr (e1);
3098 668 : e3->symtree = symtree3;
3099 668 : t = gfc_resolve_expr (e3);
3100 668 : gcc_assert (t);
3101 :
3102 668 : iname = NULL;
3103 668 : e4 = NULL;
3104 668 : switch (OMP_CLAUSE_REDUCTION_CODE (c))
3105 : {
3106 142 : case PLUS_EXPR:
3107 142 : case MINUS_EXPR:
3108 142 : e4 = gfc_add (e3, e1);
3109 142 : 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 192 : 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 668 : if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
3182 : {
3183 : /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
3184 266 : e1 = gfc_copy_expr (e1);
3185 266 : e3 = gfc_copy_expr (e3);
3186 266 : t = gfc_resolve_expr (e4);
3187 266 : gcc_assert (t);
3188 : }
3189 :
3190 : /* Create the init statement list. */
3191 668 : pushlevel ();
3192 668 : if (e2)
3193 602 : 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 668 : if (TREE_CODE (stmt) != BIND_EXPR)
3198 197 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3199 : else
3200 471 : poplevel (0, 0);
3201 668 : OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
3202 :
3203 : /* Create the merge statement list. */
3204 668 : pushlevel ();
3205 668 : if (e4)
3206 602 : 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 668 : if (TREE_CODE (stmt) != BIND_EXPR)
3211 236 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
3212 : else
3213 432 : poplevel (0, 0);
3214 668 : OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
3215 :
3216 : /* And stick the placeholder VAR_DECL into the clause as well. */
3217 668 : OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
3218 :
3219 668 : gfc_current_locus = old_loc;
3220 :
3221 668 : gfc_free_expr (e1);
3222 668 : if (e2)
3223 602 : gfc_free_expr (e2);
3224 668 : gfc_free_expr (e3);
3225 668 : if (e4)
3226 602 : gfc_free_expr (e4);
3227 668 : free (symtree1);
3228 668 : free (symtree2);
3229 668 : free (symtree3);
3230 668 : free (symtree4);
3231 668 : if (outer_sym.as)
3232 408 : gfc_free_array_spec (outer_sym.as);
3233 :
3234 668 : 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 668 : gfc_current_ns = old_ns;
3246 668 : }
3247 :
3248 : static tree
3249 3833 : gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list,
3250 : locus where, bool mark_addressable)
3251 : {
3252 3833 : omp_clause_code clause = OMP_CLAUSE_REDUCTION;
3253 3833 : 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 8598 : for (; namelist != NULL; namelist = namelist->next)
3269 4765 : if (namelist->sym->attr.referenced)
3270 : {
3271 4765 : tree t = gfc_trans_omp_variable (namelist->sym, false);
3272 4765 : if (t != error_mark_node)
3273 : {
3274 4765 : tree node = build_omp_clause (gfc_get_location (&namelist->where),
3275 : clause);
3276 4765 : OMP_CLAUSE_DECL (node) = t;
3277 4765 : if (mark_addressable)
3278 38 : TREE_ADDRESSABLE (t) = 1;
3279 4765 : if (kind == OMP_LIST_REDUCTION_INSCAN)
3280 20 : OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
3281 4765 : if (kind == OMP_LIST_REDUCTION_TASK)
3282 92 : OMP_CLAUSE_REDUCTION_TASK (node) = 1;
3283 4765 : switch (namelist->u.reduction_op)
3284 : {
3285 2316 : case OMP_REDUCTION_PLUS:
3286 2316 : OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR;
3287 2316 : 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 4765 : if (namelist->sym->attr.dimension
3328 4357 : || namelist->u.reduction_op == OMP_REDUCTION_USER
3329 4111 : || namelist->sym->attr.allocatable)
3330 668 : gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
3331 4765 : list = gfc_trans_add_clause (node, list);
3332 : }
3333 : }
3334 3833 : return list;
3335 : }
3336 :
3337 : static inline tree
3338 3398 : gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
3339 : {
3340 3398 : gfc_se se;
3341 3398 : tree result;
3342 :
3343 3398 : gfc_init_se (&se, NULL );
3344 3398 : gfc_conv_expr (&se, expr);
3345 3398 : gfc_add_block_to_block (block, &se.pre);
3346 3398 : result = gfc_evaluate_now (se.expr, block);
3347 3398 : gfc_add_block_to_block (block, &se.post);
3348 :
3349 3398 : 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 : static tree
3565 94 : handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
3566 : {
3567 94 : tree list = NULL_TREE;
3568 203 : for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
3569 : {
3570 109 : gfc_constructor *c;
3571 109 : gfc_se se;
3572 :
3573 109 : tree last = make_omp_iterator ();
3574 109 : tree iter_var = gfc_get_symbol_decl (sym);
3575 109 : tree type = TREE_TYPE (iter_var);
3576 109 : OMP_ITERATOR_VAR (last) = iter_var;
3577 109 : DECL_CHAIN (iter_var) = BLOCK_VARS (block);
3578 109 : BLOCK_VARS (block) = iter_var;
3579 :
3580 : /* begin */
3581 109 : c = gfc_constructor_first (sym->value->value.constructor);
3582 109 : gfc_init_se (&se, NULL);
3583 109 : gfc_conv_expr (&se, c->expr);
3584 109 : gfc_add_block_to_block (iter_block, &se.pre);
3585 109 : gfc_add_block_to_block (iter_block, &se.post);
3586 109 : OMP_ITERATOR_BEGIN (last) = fold_convert (type,
3587 : gfc_evaluate_now (se.expr,
3588 : iter_block));
3589 : /* end */
3590 109 : c = gfc_constructor_next (c);
3591 109 : gfc_init_se (&se, NULL);
3592 109 : gfc_conv_expr (&se, c->expr);
3593 109 : gfc_add_block_to_block (iter_block, &se.pre);
3594 109 : gfc_add_block_to_block (iter_block, &se.post);
3595 109 : OMP_ITERATOR_END (last) = fold_convert (type,
3596 : gfc_evaluate_now (se.expr,
3597 : iter_block));
3598 : /* step */
3599 109 : c = gfc_constructor_next (c);
3600 109 : tree step;
3601 109 : if (c)
3602 : {
3603 5 : gfc_init_se (&se, NULL);
3604 5 : gfc_conv_expr (&se, c->expr);
3605 5 : gfc_add_block_to_block (iter_block, &se.pre);
3606 5 : gfc_add_block_to_block (iter_block, &se.post);
3607 5 : gfc_conv_expr (&se, c->expr);
3608 5 : step = fold_convert (type,
3609 : gfc_evaluate_now (se.expr,
3610 : iter_block));
3611 : }
3612 : else
3613 104 : step = build_int_cst (type, 1);
3614 109 : OMP_ITERATOR_STEP (last) = step;
3615 : /* orig_step */
3616 109 : OMP_ITERATOR_ORIG_STEP (last) = save_expr (step);
3617 109 : TREE_CHAIN (last) = list;
3618 109 : list = last;
3619 : }
3620 94 : return list;
3621 : }
3622 :
3623 : /* To alleviate quadratic behaviour in checking each entry of a
3624 : gfc_omp_namelist against every other entry, we build a hashtable indexed by
3625 : gfc_symbol pointer, which we can use in the usual case that a map
3626 : expression has a symbol as its root term. Return a namelist based on the
3627 : root symbol used by N, building a new table in SYM_ROOTED_NL using the
3628 : gfc_omp_namelist N2 (all clauses) if we haven't done so already. */
3629 :
3630 : static gfc_omp_namelist *
3631 934 : get_symbol_rooted_namelist (hash_map<gfc_symbol *,
3632 : gfc_omp_namelist *> *&sym_rooted_nl,
3633 : gfc_omp_namelist *n,
3634 : gfc_omp_namelist *n2, bool *sym_based)
3635 : {
3636 : /* Early-out if we have a NULL clause list (e.g. for OpenACC). */
3637 934 : if (!n2)
3638 : return NULL;
3639 :
3640 897 : gfc_symbol *use_sym = NULL;
3641 :
3642 : /* We're only interested in cases where we have an expression, e.g. a
3643 : component access. */
3644 897 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE && n->expr->symtree)
3645 897 : use_sym = n->expr->symtree->n.sym;
3646 :
3647 897 : *sym_based = false;
3648 :
3649 897 : if (!use_sym)
3650 : return n2;
3651 :
3652 897 : if (!sym_rooted_nl)
3653 : {
3654 388 : sym_rooted_nl = new hash_map<gfc_symbol *, gfc_omp_namelist *> ();
3655 :
3656 1715 : for (; n2 != NULL; n2 = n2->next)
3657 : {
3658 1327 : if (!n2->expr
3659 1326 : || n2->expr->expr_type != EXPR_VARIABLE
3660 1326 : || !n2->expr->symtree)
3661 1 : continue;
3662 :
3663 1326 : gfc_omp_namelist *nl_copy = gfc_get_omp_namelist ();
3664 1326 : memcpy (nl_copy, n2, sizeof *nl_copy);
3665 1326 : nl_copy->u2.duplicate_of = n2;
3666 1326 : nl_copy->next = NULL;
3667 :
3668 1326 : gfc_symbol *idx_sym = n2->expr->symtree->n.sym;
3669 :
3670 1326 : bool existed;
3671 1326 : gfc_omp_namelist *&entry
3672 1326 : = sym_rooted_nl->get_or_insert (idx_sym, &existed);
3673 1326 : if (existed)
3674 881 : nl_copy->next = entry;
3675 1326 : entry = nl_copy;
3676 : }
3677 : }
3678 :
3679 897 : gfc_omp_namelist **n2_sym = sym_rooted_nl->get (use_sym);
3680 :
3681 897 : if (n2_sym)
3682 : {
3683 897 : *sym_based = true;
3684 897 : return *n2_sym;
3685 : }
3686 :
3687 : return NULL;
3688 : }
3689 :
3690 : /* Helper function for gfc_trans_omp_clauses. Adjust existing and create new
3691 : map nodes for derived-type component array descriptors. Return true if the
3692 : mapping has to be dropped. */
3693 :
3694 : static bool
3695 1191 : gfc_map_array_descriptor (
3696 : tree &node, tree &node2, tree &node3, tree &node4, tree descr, bool openacc,
3697 : location_t map_loc, stmtblock_t *block, gfc_exec_op op, gfc_omp_namelist *n,
3698 : hash_map<gfc_symbol *, gfc_omp_namelist *> *&sym_rooted_nl, gfc_se se,
3699 : gfc_omp_clauses *clauses, bool mid_desc_p)
3700 : {
3701 1191 : tree type = TREE_TYPE (descr);
3702 1191 : tree ptr = gfc_conv_descriptor_data_get (descr);
3703 1191 : ptr = build_fold_indirect_ref (ptr);
3704 1191 : OMP_CLAUSE_DECL (node) = ptr;
3705 1191 : int rank = GFC_TYPE_ARRAY_RANK (type);
3706 1191 : OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, descr, rank);
3707 1191 : tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3708 :
3709 1191 : gomp_map_kind map_kind = OMP_CLAUSE_MAP_KIND (node);
3710 1191 : if (GOMP_MAP_COPY_TO_P (map_kind) || map_kind == GOMP_MAP_ALLOC)
3711 : {
3712 842 : if (mid_desc_p)
3713 : {
3714 : /* For an intermediate descriptor, the pointee (i.e. the actual array
3715 : content) is mapped in a separate set of nodes. This ALLOC is only
3716 : emitted to comply with the group layout expected by the gimplifier.
3717 : */
3718 89 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3719 89 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3720 89 : OMP_CLAUSE_MAP_GIMPLE_ONLY (node) = 1;
3721 : }
3722 : else
3723 753 : map_kind
3724 1250 : = ((GOMP_MAP_ALWAYS_P (map_kind) || gfc_expr_attr (n->expr).pointer)
3725 753 : ? GOMP_MAP_ALWAYS_TO
3726 : : GOMP_MAP_TO);
3727 : }
3728 349 : else if (n->u.map.op == OMP_MAP_RELEASE || n->u.map.op == OMP_MAP_DELETE)
3729 : ;
3730 344 : else if (op == EXEC_OMP_TARGET_EXIT_DATA || op == EXEC_OACC_EXIT_DATA)
3731 : map_kind = GOMP_MAP_RELEASE;
3732 31 : else if (mid_desc_p)
3733 : {
3734 : /* For an intermediate descriptor, the pointee (i.e. the actual array
3735 : content) is mapped in a separate set of nodes. This ALLOC is only
3736 : emitted to comply with the group layout expected by the gimplifier. */
3737 1 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
3738 1 : OMP_CLAUSE_SIZE (node) = size_zero_node;
3739 1 : OMP_CLAUSE_MAP_GIMPLE_ONLY (node) = 1;
3740 : }
3741 : else
3742 : map_kind = GOMP_MAP_ALLOC;
3743 :
3744 1191 : if (!openacc && n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred)
3745 : {
3746 42 : gcc_assert (se.string_length);
3747 42 : tree len = fold_convert (size_type_node, se.string_length);
3748 42 : elemsz = gfc_get_char_type (n->expr->ts.kind);
3749 42 : elemsz = TYPE_SIZE_UNIT (elemsz);
3750 42 : elemsz = fold_build2 (MULT_EXPR, size_type_node, len, elemsz);
3751 42 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3752 42 : OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
3753 42 : OMP_CLAUSE_DECL (node4) = se.string_length;
3754 42 : OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
3755 : }
3756 1191 : elemsz = fold_convert (gfc_array_index_type, elemsz);
3757 1191 : OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
3758 : OMP_CLAUSE_SIZE (node), elemsz);
3759 :
3760 1191 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3761 1191 : if (map_kind == GOMP_MAP_RELEASE || map_kind == GOMP_MAP_DELETE)
3762 : {
3763 318 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
3764 318 : OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
3765 : }
3766 : else
3767 873 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
3768 1191 : OMP_CLAUSE_DECL (node2) = descr;
3769 1191 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
3770 :
3771 1191 : if (!openacc)
3772 : {
3773 1051 : if (n->expr->ts.type == BT_DERIVED
3774 18 : && n->expr->ts.u.derived->attr.alloc_comp)
3775 : {
3776 : /* Save array descriptor for use
3777 : in gfc_omp_deep_mapping{,_p,_cnt}; force
3778 : evaluate to ensure that it is
3779 : not gimplified + is a decl. */
3780 12 : tree tmp = OMP_CLAUSE_SIZE (node);
3781 12 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
3782 12 : gfc_add_modify_loc (map_loc, block, var, tmp);
3783 12 : OMP_CLAUSE_SIZE (node) = var;
3784 12 : gfc_allocate_lang_decl (var);
3785 12 : GFC_DECL_SAVED_DESCRIPTOR (var) = descr;
3786 : }
3787 :
3788 : /* If we don't have a mapping of a smaller part
3789 : of the array -- or we can't prove that we do
3790 : statically -- set this flag. If there is a
3791 : mapping of a smaller part of the array after
3792 : all, this will turn into a no-op at
3793 : runtime. */
3794 1051 : OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (node) = 1;
3795 :
3796 1051 : bool drop_mapping = false;
3797 :
3798 1051 : if (!mid_desc_p)
3799 : {
3800 879 : gfc_omp_namelist *n2 = clauses->lists[OMP_LIST_MAP];
3801 :
3802 879 : bool sym_based;
3803 879 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n, n2, &sym_based);
3804 :
3805 3179 : for (; n2 != NULL; n2 = n2->next)
3806 : {
3807 2586 : if ((!sym_based && n == n2)
3808 2586 : || (sym_based && n == n2->u2.duplicate_of) || !n2->expr)
3809 617 : continue;
3810 :
3811 1969 : if (!gfc_omp_expr_prefix_same (n->expr, n2->expr))
3812 1683 : continue;
3813 :
3814 286 : gfc_ref *ref1 = n->expr->ref;
3815 286 : gfc_ref *ref2 = n2->expr->ref;
3816 :
3817 : /* We know ref1 and ref2 overlap. We're
3818 : interested in whether ref2 describes a
3819 : smaller part of the array than ref1, which
3820 : we already know refers to the full
3821 : array. */
3822 :
3823 644 : while (ref1->next && ref2->next)
3824 : {
3825 : ref1 = ref1->next;
3826 : ref2 = ref2->next;
3827 : }
3828 :
3829 286 : if (ref2->next
3830 286 : || (ref2->type == REF_ARRAY
3831 286 : && (ref2->u.ar.type == AR_ELEMENT
3832 286 : || (ref2->u.ar.type == AR_SECTION))))
3833 : {
3834 : drop_mapping = true;
3835 : break;
3836 : }
3837 : }
3838 879 : if (drop_mapping)
3839 286 : return true;
3840 : }
3841 : }
3842 :
3843 905 : if (mid_desc_p && GOMP_MAP_COPY_FROM_P (OMP_CLAUSE_MAP_KIND (node)))
3844 82 : node = NULL_TREE;
3845 :
3846 905 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
3847 905 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH);
3848 905 : OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (descr);
3849 : /* Similar to gfc_trans_omp_array_section (details
3850 : there), we add/keep the cast for OpenMP to prevent
3851 : that an 'alloc:' gets added for node3 ('desc.data')
3852 : as that is part of the whole descriptor (node3).
3853 : TODO: Remove once the ME handles this properly. */
3854 905 : if (!openacc)
3855 765 : OMP_CLAUSE_DECL (node3) = fold_convert (TREE_TYPE (TREE_OPERAND (ptr, 0)),
3856 : OMP_CLAUSE_DECL (node3));
3857 : else
3858 140 : STRIP_NOPS (OMP_CLAUSE_DECL (node3));
3859 905 : OMP_CLAUSE_SIZE (node3) = size_zero_node;
3860 905 : if (mid_desc_p)
3861 172 : OMP_CLAUSE_MAP_SIZE_NEEDS_ADJUSTMENT (node3) = 1;
3862 :
3863 : return false;
3864 : }
3865 :
3866 : static tree
3867 31968 : gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
3868 : locus where, bool declare_simd = false,
3869 : bool openacc = false, gfc_exec_op op = EXEC_NOP)
3870 : {
3871 31968 : tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
3872 31968 : tree iterator = NULL_TREE;
3873 31968 : tree tree_block = NULL_TREE;
3874 31968 : stmtblock_t iter_block;
3875 31968 : int list, ifc;
3876 31968 : enum omp_clause_code clause_code;
3877 31968 : gfc_omp_namelist *prev = NULL;
3878 31968 : gfc_se se;
3879 31968 : vec<gfc_symbol *> descriptors = vNULL;
3880 :
3881 31968 : if (clauses == NULL)
3882 : return NULL_TREE;
3883 :
3884 31956 : hash_map<gfc_symbol *, gfc_omp_namelist *> *sym_rooted_nl = NULL;
3885 :
3886 1278240 : for (list = 0; list < OMP_LIST_NUM; list++)
3887 : {
3888 1246284 : gfc_omp_namelist *n = clauses->lists[list];
3889 :
3890 1246284 : if (n == NULL)
3891 1218342 : continue;
3892 27942 : switch (list)
3893 : {
3894 3833 : case OMP_LIST_REDUCTION:
3895 3833 : case OMP_LIST_REDUCTION_INSCAN:
3896 3833 : case OMP_LIST_REDUCTION_TASK:
3897 3833 : case OMP_LIST_IN_REDUCTION:
3898 3833 : case OMP_LIST_TASK_REDUCTION:
3899 : /* An OpenACC async clause indicates the need to set reduction
3900 : arguments addressable, to allow asynchronous copy-out. */
3901 3833 : omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses,
3902 3833 : where, clauses->async);
3903 3833 : break;
3904 6429 : case OMP_LIST_PRIVATE:
3905 6429 : clause_code = OMP_CLAUSE_PRIVATE;
3906 6429 : goto add_clause;
3907 1064 : case OMP_LIST_SHARED:
3908 1064 : clause_code = OMP_CLAUSE_SHARED;
3909 1064 : goto add_clause;
3910 1066 : case OMP_LIST_FIRSTPRIVATE:
3911 1066 : clause_code = OMP_CLAUSE_FIRSTPRIVATE;
3912 1066 : goto add_clause;
3913 1627 : case OMP_LIST_LASTPRIVATE:
3914 1627 : clause_code = OMP_CLAUSE_LASTPRIVATE;
3915 1627 : goto add_clause;
3916 96 : case OMP_LIST_COPYIN:
3917 96 : clause_code = OMP_CLAUSE_COPYIN;
3918 96 : goto add_clause;
3919 74 : case OMP_LIST_COPYPRIVATE:
3920 74 : clause_code = OMP_CLAUSE_COPYPRIVATE;
3921 74 : goto add_clause;
3922 61 : case OMP_LIST_UNIFORM:
3923 61 : clause_code = OMP_CLAUSE_UNIFORM;
3924 61 : goto add_clause;
3925 51 : case OMP_LIST_USE_DEVICE:
3926 51 : case OMP_LIST_USE_DEVICE_PTR:
3927 51 : clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
3928 51 : goto add_clause;
3929 922 : case OMP_LIST_USE_DEVICE_ADDR:
3930 922 : clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
3931 922 : goto add_clause;
3932 43 : case OMP_LIST_IS_DEVICE_PTR:
3933 43 : clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
3934 43 : goto add_clause;
3935 112 : case OMP_LIST_HAS_DEVICE_ADDR:
3936 112 : clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
3937 112 : goto add_clause;
3938 2 : case OMP_LIST_NONTEMPORAL:
3939 2 : clause_code = OMP_CLAUSE_NONTEMPORAL;
3940 2 : goto add_clause;
3941 9 : case OMP_LIST_SCAN_IN:
3942 9 : clause_code = OMP_CLAUSE_INCLUSIVE;
3943 9 : goto add_clause;
3944 7 : case OMP_LIST_SCAN_EX:
3945 7 : clause_code = OMP_CLAUSE_EXCLUSIVE;
3946 7 : goto add_clause;
3947 4 : case OMP_LIST_USE:
3948 4 : clause_code = OMP_CLAUSE_USE;
3949 4 : goto add_clause;
3950 55 : case OMP_LIST_INTEROP:
3951 55 : clause_code = OMP_CLAUSE_INTEROP;
3952 55 : goto add_clause;
3953 :
3954 11622 : add_clause:
3955 11622 : omp_clauses
3956 11622 : = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
3957 : declare_simd);
3958 11622 : break;
3959 :
3960 : case OMP_LIST_DESTROY:
3961 12 : for (; n != NULL; n = n->next)
3962 9 : if (n->sym->attr.referenced)
3963 : {
3964 9 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
3965 9 : if (t != error_mark_node)
3966 : {
3967 9 : tree node
3968 9 : = build_omp_clause (input_location, OMP_CLAUSE_DESTROY);
3969 9 : OMP_CLAUSE_DECL (node) = t;
3970 9 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3971 9 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
3972 : }
3973 : }
3974 : break;
3975 :
3976 : case OMP_LIST_INIT:
3977 : {
3978 : tree pref_type = NULL_TREE;
3979 : const char *last = NULL;
3980 32 : for (; n != NULL; n = n->next)
3981 26 : if (n->sym->attr.referenced)
3982 : {
3983 26 : tree t = gfc_trans_omp_variable (n->sym, false);
3984 26 : if (t == error_mark_node)
3985 0 : continue;
3986 26 : tree node = build_omp_clause (input_location,
3987 : OMP_CLAUSE_INIT);
3988 26 : OMP_CLAUSE_DECL (node) = t;
3989 26 : TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
3990 26 : if (n->u.init.target)
3991 19 : OMP_CLAUSE_INIT_TARGET (node) = 1;
3992 26 : if (n->u.init.targetsync)
3993 10 : OMP_CLAUSE_INIT_TARGETSYNC (node) = 1;
3994 26 : if (last != n->u2.init_interop)
3995 : {
3996 6 : last = n->u2.init_interop;
3997 6 : if (n->u2.init_interop == NULL)
3998 : pref_type = NULL_TREE;
3999 : else
4000 : {
4001 5 : pref_type = build_string (n->u.init.len,
4002 : n->u2.init_interop);
4003 5 : TREE_TYPE (pref_type)
4004 10 : = build_array_type_nelts (unsigned_char_type_node,
4005 5 : n->u.init.len);
4006 : }
4007 : }
4008 26 : OMP_CLAUSE_INIT_PREFER_TYPE (node) = pref_type;
4009 26 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4010 : }
4011 : break;
4012 : }
4013 :
4014 : case OMP_LIST_ALIGNED:
4015 256 : for (; n != NULL; n = n->next)
4016 149 : if (n->sym->attr.referenced || declare_simd)
4017 : {
4018 149 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
4019 149 : if (t != error_mark_node)
4020 : {
4021 149 : tree node = build_omp_clause (input_location,
4022 : OMP_CLAUSE_ALIGNED);
4023 149 : OMP_CLAUSE_DECL (node) = t;
4024 149 : if (n->expr)
4025 : {
4026 148 : tree alignment_var;
4027 :
4028 148 : if (declare_simd)
4029 5 : alignment_var = gfc_conv_constant_to_tree (n->expr);
4030 : else
4031 : {
4032 143 : gfc_init_se (&se, NULL);
4033 143 : gfc_conv_expr (&se, n->expr);
4034 143 : gfc_add_block_to_block (block, &se.pre);
4035 143 : alignment_var = gfc_evaluate_now (se.expr, block);
4036 143 : gfc_add_block_to_block (block, &se.post);
4037 : }
4038 148 : OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
4039 : }
4040 149 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4041 : }
4042 : }
4043 : break;
4044 : case OMP_LIST_ALLOCATE:
4045 : {
4046 : tree allocator_ = NULL_TREE;
4047 : gfc_expr *alloc_expr = NULL;
4048 367 : for (; n != NULL; n = n->next)
4049 201 : if (n->sym->attr.referenced)
4050 : {
4051 201 : tree t = gfc_trans_omp_variable (n->sym, false);
4052 201 : if (t != error_mark_node)
4053 : {
4054 201 : tree node = build_omp_clause (input_location,
4055 : OMP_CLAUSE_ALLOCATE);
4056 201 : OMP_CLAUSE_DECL (node) = t;
4057 201 : if (n->u2.allocator)
4058 : {
4059 138 : if (alloc_expr != n->u2.allocator)
4060 : {
4061 116 : gfc_init_se (&se, NULL);
4062 116 : gfc_conv_expr (&se, n->u2.allocator);
4063 116 : gfc_add_block_to_block (block, &se.pre);
4064 116 : t = se.expr;
4065 116 : if (DECL_P (t) && se.post.head == NULL_TREE)
4066 22 : allocator_ = (POINTER_TYPE_P (TREE_TYPE (t))
4067 11 : ? build_fold_indirect_ref (t): t);
4068 : else
4069 105 : allocator_ = gfc_evaluate_now (t, block);
4070 116 : gfc_add_block_to_block (block, &se.post);
4071 : }
4072 138 : OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
4073 : }
4074 201 : alloc_expr = n->u2.allocator;
4075 201 : if (n->u.align)
4076 : {
4077 51 : tree align_;
4078 51 : gfc_init_se (&se, NULL);
4079 51 : gfc_conv_expr (&se, n->u.align);
4080 51 : gcc_assert (CONSTANT_CLASS_P (se.expr)
4081 : && se.pre.head == NULL
4082 : && se.post.head == NULL);
4083 51 : align_ = se.expr;
4084 51 : OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
4085 : }
4086 201 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4087 : }
4088 : }
4089 : else
4090 0 : alloc_expr = n->u2.allocator;
4091 : }
4092 : break;
4093 : case OMP_LIST_LINEAR:
4094 : {
4095 : gfc_expr *last_step_expr = NULL;
4096 : tree last_step = NULL_TREE;
4097 : bool last_step_parm = false;
4098 :
4099 1240 : for (; n != NULL; n = n->next)
4100 : {
4101 771 : if (n->expr)
4102 : {
4103 752 : last_step_expr = n->expr;
4104 752 : last_step = NULL_TREE;
4105 752 : last_step_parm = false;
4106 : }
4107 771 : if (n->sym->attr.referenced || declare_simd)
4108 : {
4109 771 : tree t = gfc_trans_omp_variable (n->sym, declare_simd);
4110 771 : if (t != error_mark_node)
4111 : {
4112 771 : tree node = build_omp_clause (input_location,
4113 : OMP_CLAUSE_LINEAR);
4114 771 : OMP_CLAUSE_DECL (node) = t;
4115 771 : omp_clause_linear_kind kind;
4116 771 : switch (n->u.linear.op)
4117 : {
4118 : case OMP_LINEAR_DEFAULT:
4119 : kind = OMP_CLAUSE_LINEAR_DEFAULT;
4120 : break;
4121 : case OMP_LINEAR_REF:
4122 : kind = OMP_CLAUSE_LINEAR_REF;
4123 : break;
4124 : case OMP_LINEAR_VAL:
4125 : kind = OMP_CLAUSE_LINEAR_VAL;
4126 : break;
4127 : case OMP_LINEAR_UVAL:
4128 : kind = OMP_CLAUSE_LINEAR_UVAL;
4129 : break;
4130 0 : default:
4131 0 : gcc_unreachable ();
4132 : }
4133 771 : OMP_CLAUSE_LINEAR_KIND (node) = kind;
4134 771 : OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node)
4135 771 : = n->u.linear.old_modifier;
4136 771 : if (last_step_expr && last_step == NULL_TREE)
4137 : {
4138 752 : if (!declare_simd)
4139 : {
4140 671 : gfc_init_se (&se, NULL);
4141 671 : gfc_conv_expr (&se, last_step_expr);
4142 671 : gfc_add_block_to_block (block, &se.pre);
4143 671 : last_step = gfc_evaluate_now (se.expr, block);
4144 671 : gfc_add_block_to_block (block, &se.post);
4145 : }
4146 81 : else if (last_step_expr->expr_type == EXPR_VARIABLE)
4147 : {
4148 2 : gfc_symbol *s = last_step_expr->symtree->n.sym;
4149 2 : last_step = gfc_trans_omp_variable (s, true);
4150 2 : last_step_parm = true;
4151 : }
4152 : else
4153 79 : last_step
4154 79 : = gfc_conv_constant_to_tree (last_step_expr);
4155 : }
4156 771 : if (last_step_parm)
4157 : {
4158 2 : OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
4159 2 : OMP_CLAUSE_LINEAR_STEP (node) = last_step;
4160 : }
4161 : else
4162 : {
4163 769 : if (kind == OMP_CLAUSE_LINEAR_REF)
4164 : {
4165 34 : tree type;
4166 34 : if (n->sym->attr.flavor == FL_PROCEDURE)
4167 : {
4168 0 : type = gfc_get_function_type (n->sym);
4169 0 : type = build_pointer_type (type);
4170 : }
4171 : else
4172 34 : type = gfc_sym_type (n->sym);
4173 34 : if (POINTER_TYPE_P (type))
4174 34 : type = TREE_TYPE (type);
4175 : /* Otherwise to be determined what exactly
4176 : should be done. */
4177 34 : tree t = fold_convert (sizetype, last_step);
4178 34 : t = size_binop (MULT_EXPR, t,
4179 : TYPE_SIZE_UNIT (type));
4180 34 : OMP_CLAUSE_LINEAR_STEP (node) = t;
4181 : }
4182 : else
4183 : {
4184 735 : tree type
4185 735 : = gfc_typenode_for_spec (&n->sym->ts);
4186 735 : OMP_CLAUSE_LINEAR_STEP (node)
4187 1470 : = fold_convert (type, last_step);
4188 : }
4189 : }
4190 771 : if (n->sym->attr.dimension || n->sym->attr.allocatable)
4191 222 : OMP_CLAUSE_LINEAR_ARRAY (node) = 1;
4192 771 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4193 : }
4194 : }
4195 : }
4196 : }
4197 : break;
4198 : case OMP_LIST_AFFINITY:
4199 : case OMP_LIST_DEPEND:
4200 : iterator = NULL_TREE;
4201 : prev = NULL;
4202 : prev_clauses = omp_clauses;
4203 1582 : for (; n != NULL; n = n->next)
4204 : {
4205 857 : if (iterator && prev->u2.ns != n->u2.ns)
4206 : {
4207 12 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4208 12 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
4209 26 : for (tree c = omp_clauses; c != prev_clauses;
4210 14 : c = OMP_CLAUSE_CHAIN (c))
4211 28 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
4212 14 : OMP_CLAUSE_DECL (c));
4213 : prev_clauses = omp_clauses;
4214 : iterator = NULL_TREE;
4215 : }
4216 857 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
4217 : {
4218 46 : gfc_init_block (&iter_block);
4219 46 : tree_block = make_node (BLOCK);
4220 46 : TREE_USED (tree_block) = 1;
4221 46 : BLOCK_VARS (tree_block) = NULL_TREE;
4222 46 : iterator = handle_iterator (n->u2.ns, block,
4223 : tree_block);
4224 : }
4225 857 : if (!iterator)
4226 802 : gfc_init_block (&iter_block);
4227 857 : prev = n;
4228 857 : if (list == OMP_LIST_DEPEND
4229 831 : && (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
4230 831 : || n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST))
4231 : {
4232 228 : tree vec = NULL_TREE;
4233 228 : unsigned int i;
4234 228 : bool is_depend
4235 : = n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST;
4236 228 : for (i = 0; ; i++)
4237 : {
4238 1219 : tree addend = integer_zero_node, t;
4239 1219 : bool neg = false;
4240 1219 : if (n->sym && n->expr)
4241 : {
4242 558 : addend = gfc_conv_constant_to_tree (n->expr);
4243 558 : if (TREE_CODE (addend) == INTEGER_CST
4244 558 : && tree_int_cst_sgn (addend) == -1)
4245 : {
4246 407 : neg = true;
4247 407 : addend = const_unop (NEGATE_EXPR,
4248 407 : TREE_TYPE (addend), addend);
4249 : }
4250 : }
4251 :
4252 1219 : if (n->sym == NULL)
4253 0 : t = null_pointer_node; /* "omp_cur_iteration - 1". */
4254 : else
4255 1219 : t = gfc_trans_omp_variable (n->sym, false);
4256 1219 : if (t != error_mark_node)
4257 : {
4258 1219 : if (i < vec_safe_length (doacross_steps)
4259 426 : && !integer_zerop (addend)
4260 630 : && (*doacross_steps)[i])
4261 : {
4262 204 : tree step = (*doacross_steps)[i];
4263 204 : addend = fold_convert (TREE_TYPE (step), addend);
4264 204 : addend = build2 (TRUNC_DIV_EXPR,
4265 204 : TREE_TYPE (step), addend, step);
4266 : }
4267 1219 : vec = tree_cons (addend, t, vec);
4268 1219 : if (neg)
4269 407 : OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
4270 : }
4271 1219 : if (n->next == NULL
4272 1057 : || n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
4273 : break;
4274 991 : n = n->next;
4275 991 : }
4276 228 : if (vec == NULL_TREE)
4277 0 : continue;
4278 :
4279 228 : tree node = build_omp_clause (input_location,
4280 : OMP_CLAUSE_DOACROSS);
4281 228 : OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
4282 228 : OMP_CLAUSE_DOACROSS_DEPEND (node) = is_depend;
4283 228 : OMP_CLAUSE_DECL (node) = nreverse (vec);
4284 228 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4285 228 : continue;
4286 228 : }
4287 :
4288 629 : if (n->sym && !n->sym->attr.referenced)
4289 0 : continue;
4290 :
4291 655 : tree node = build_omp_clause (input_location,
4292 : list == OMP_LIST_DEPEND
4293 : ? OMP_CLAUSE_DEPEND
4294 : : OMP_CLAUSE_AFFINITY);
4295 629 : if (n->sym == NULL) /* omp_all_memory */
4296 9 : OMP_CLAUSE_DECL (node) = null_pointer_node;
4297 620 : else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
4298 : {
4299 404 : tree decl = gfc_trans_omp_variable (n->sym, false);
4300 404 : if (gfc_omp_privatize_by_reference (decl))
4301 62 : decl = build_fold_indirect_ref (decl);
4302 404 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4303 : {
4304 23 : decl = gfc_conv_descriptor_data_get (decl);
4305 23 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
4306 23 : decl = build_fold_indirect_ref (decl);
4307 : }
4308 381 : else if (n->sym->attr.allocatable || n->sym->attr.pointer)
4309 22 : decl = build_fold_indirect_ref (decl);
4310 359 : else if (DECL_P (decl))
4311 326 : TREE_ADDRESSABLE (decl) = 1;
4312 404 : OMP_CLAUSE_DECL (node) = decl;
4313 404 : }
4314 : else
4315 : {
4316 216 : tree ptr;
4317 216 : gfc_init_se (&se, NULL);
4318 : /* The first ref can be an element selection on the base
4319 : object while the full expression still denotes an array,
4320 : e.g. x(j)%a. Pick the lowering path from the overall
4321 : expression rank, not from the first REF_ARRAY. */
4322 216 : if (n->expr->rank == 0)
4323 : {
4324 135 : gfc_conv_expr_reference (&se, n->expr);
4325 135 : ptr = se.expr;
4326 : }
4327 : else
4328 : {
4329 81 : gfc_conv_expr_descriptor (&se, n->expr);
4330 81 : ptr = gfc_conv_array_data (se.expr);
4331 : }
4332 216 : gfc_add_block_to_block (&iter_block, &se.pre);
4333 216 : gfc_add_block_to_block (&iter_block, &se.post);
4334 216 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4335 216 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
4336 : }
4337 629 : if (list == OMP_LIST_DEPEND)
4338 603 : switch (n->u.depend_doacross_op)
4339 : {
4340 228 : case OMP_DEPEND_IN:
4341 228 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN;
4342 228 : break;
4343 258 : case OMP_DEPEND_OUT:
4344 258 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT;
4345 258 : break;
4346 55 : case OMP_DEPEND_INOUT:
4347 55 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT;
4348 55 : break;
4349 9 : case OMP_DEPEND_INOUTSET:
4350 9 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET;
4351 9 : break;
4352 15 : case OMP_DEPEND_MUTEXINOUTSET:
4353 15 : OMP_CLAUSE_DEPEND_KIND (node)
4354 15 : = OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
4355 15 : break;
4356 38 : case OMP_DEPEND_DEPOBJ:
4357 38 : OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
4358 38 : break;
4359 0 : default:
4360 0 : gcc_unreachable ();
4361 : }
4362 629 : if (!iterator)
4363 574 : gfc_add_block_to_block (block, &iter_block);
4364 629 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
4365 : }
4366 725 : if (iterator)
4367 : {
4368 34 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4369 34 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
4370 76 : for (tree c = omp_clauses; c != prev_clauses;
4371 42 : c = OMP_CLAUSE_CHAIN (c))
4372 84 : OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
4373 42 : OMP_CLAUSE_DECL (c));
4374 : }
4375 : break;
4376 : case OMP_LIST_MAP:
4377 : iterator = NULL_TREE;
4378 : prev = NULL;
4379 : prev_clauses = omp_clauses;
4380 25203 : for (; n != NULL; n = n->next)
4381 : {
4382 16007 : if (!openacc)
4383 : {
4384 7423 : if (n->u3.udm)
4385 7 : gfc_error ("Sorry, declared mapper %qs, used for %qs at %L, "
4386 : "is not yet supported",
4387 7 : n->u3.udm->requested_mapper_id[0] != '\0'
4388 : ? n->u3.udm->requested_mapper_id : "default",
4389 7 : n->sym->name, &n->where);
4390 :
4391 : // Remove duplicates
4392 7423 : bool skip = false;
4393 17113 : for (gfc_omp_namelist *n2 = n->next; n2 != NULL;
4394 9690 : n2 = n2->next)
4395 : {
4396 9959 : if (n2->sym == n->sym
4397 9959 : && gfc_dep_compare_expr (n2->expr, n->expr) == 0)
4398 : {
4399 315 : if (n2->u.map.op == n->u.map.op)
4400 : {
4401 : skip = true;
4402 : break;
4403 : }
4404 297 : else if ((n2->u.map.op & ~OMP_MAP_TOFROM)
4405 297 : == (n->u.map.op & ~OMP_MAP_TOFROM))
4406 : {
4407 251 : n2->u.map.op = (enum gfc_omp_map_op) (
4408 251 : n->u.map.op | n2->u.map.op);
4409 251 : skip = true;
4410 251 : break;
4411 : }
4412 : }
4413 : }
4414 7423 : if (skip)
4415 833 : continue;
4416 : }
4417 :
4418 15738 : if (!n->sym->attr.referenced
4419 15738 : || n->sym->attr.flavor == FL_PARAMETER)
4420 9 : continue;
4421 :
4422 15729 : if (iterator && prev->u2.ns != n->u2.ns)
4423 : {
4424 : /* Finish previous iterator group. */
4425 25 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
4426 25 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
4427 175 : for (tree c = omp_clauses; c != prev_clauses;
4428 75 : c = OMP_CLAUSE_CHAIN (c))
4429 75 : if (OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_FIRSTPRIVATE_POINTER
4430 75 : && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_FIRSTPRIVATE_REFERENCE)
4431 75 : OMP_CLAUSE_ITERATORS (c) = iterator;
4432 : prev_clauses = omp_clauses;
4433 : iterator = NULL_TREE;
4434 : }
4435 15729 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
4436 : {
4437 : /* Start a new iterator group. */
4438 37 : gfc_init_block (&iter_block);
4439 37 : tree_block = make_node (BLOCK);
4440 37 : TREE_USED (tree_block) = 1;
4441 37 : BLOCK_VARS (tree_block) = NULL_TREE;
4442 37 : prev_clauses = omp_clauses;
4443 37 : iterator = handle_iterator (n->u2.ns, block, tree_block);
4444 : }
4445 15729 : if (!iterator)
4446 15690 : gfc_init_block (&iter_block);
4447 15729 : prev = n;
4448 :
4449 15729 : location_t map_loc = gfc_get_location (&n->where);
4450 15729 : bool always_modifier = false;
4451 15729 : tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4452 15729 : tree node2 = NULL_TREE;
4453 15729 : tree node3 = NULL_TREE;
4454 15729 : tree node4 = NULL_TREE;
4455 15729 : tree node5 = NULL_TREE;
4456 :
4457 : /* OpenMP: automatically map pointer targets with the pointer;
4458 : hence, always update the descriptor/pointer itself. */
4459 15729 : if (!openacc
4460 15729 : && ((n->expr == NULL && n->sym->attr.pointer)
4461 14941 : || (n->expr && gfc_expr_attr (n->expr).pointer)))
4462 1393 : always_modifier = true;
4463 :
4464 15729 : if (n->u.map.readonly)
4465 22 : OMP_CLAUSE_MAP_READONLY (node) = 1;
4466 :
4467 15729 : switch (n->u.map.op)
4468 : {
4469 1098 : case OMP_MAP_ALLOC:
4470 1098 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
4471 1098 : break;
4472 64 : case OMP_MAP_IF_PRESENT:
4473 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
4474 64 : break;
4475 66 : case OMP_MAP_ATTACH:
4476 66 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
4477 66 : break;
4478 4347 : case OMP_MAP_TO:
4479 4347 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
4480 4347 : break;
4481 3110 : case OMP_MAP_FROM:
4482 3110 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
4483 3110 : break;
4484 4526 : case OMP_MAP_TOFROM:
4485 4526 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
4486 4526 : break;
4487 35 : case OMP_MAP_ALWAYS_TO:
4488 35 : always_modifier = true;
4489 35 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
4490 35 : break;
4491 17 : case OMP_MAP_ALWAYS_FROM:
4492 17 : always_modifier = true;
4493 17 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
4494 17 : break;
4495 171 : case OMP_MAP_ALWAYS_TOFROM:
4496 171 : always_modifier = true;
4497 171 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
4498 171 : break;
4499 15 : case OMP_MAP_PRESENT_ALLOC:
4500 15 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC);
4501 15 : break;
4502 14 : case OMP_MAP_PRESENT_TO:
4503 14 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO);
4504 14 : break;
4505 5 : case OMP_MAP_PRESENT_FROM:
4506 5 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM);
4507 5 : break;
4508 3 : case OMP_MAP_PRESENT_TOFROM:
4509 3 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM);
4510 3 : break;
4511 10 : case OMP_MAP_ALWAYS_PRESENT_TO:
4512 10 : always_modifier = true;
4513 10 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO);
4514 10 : break;
4515 4 : case OMP_MAP_ALWAYS_PRESENT_FROM:
4516 4 : always_modifier = true;
4517 4 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM);
4518 4 : break;
4519 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
4520 2 : always_modifier = true;
4521 2 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM);
4522 2 : break;
4523 457 : case OMP_MAP_RELEASE:
4524 457 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
4525 457 : break;
4526 80 : case OMP_MAP_DELETE:
4527 80 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
4528 80 : break;
4529 44 : case OMP_MAP_DETACH:
4530 44 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
4531 44 : break;
4532 64 : case OMP_MAP_FORCE_ALLOC:
4533 64 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
4534 64 : break;
4535 465 : case OMP_MAP_FORCE_TO:
4536 465 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
4537 465 : break;
4538 577 : case OMP_MAP_FORCE_FROM:
4539 577 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
4540 577 : break;
4541 0 : case OMP_MAP_FORCE_TOFROM:
4542 0 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
4543 0 : break;
4544 545 : case OMP_MAP_FORCE_PRESENT:
4545 545 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
4546 545 : break;
4547 10 : case OMP_MAP_FORCE_DEVICEPTR:
4548 10 : OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
4549 10 : break;
4550 0 : default:
4551 0 : gcc_unreachable ();
4552 : }
4553 :
4554 15729 : tree decl = gfc_trans_omp_variable (n->sym, false);
4555 15729 : if (DECL_P (decl))
4556 15729 : TREE_ADDRESSABLE (decl) = 1;
4557 :
4558 15729 : gfc_ref *lastref = NULL;
4559 :
4560 15729 : if (n->expr)
4561 15022 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4562 9215 : if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
4563 9215 : lastref = ref;
4564 :
4565 5807 : bool allocatable = false, pointer = false;
4566 :
4567 5807 : if (lastref && lastref->type == REF_COMPONENT)
4568 : {
4569 457 : gfc_component *c = lastref->u.c.component;
4570 :
4571 457 : if (c->ts.type == BT_CLASS)
4572 : {
4573 24 : pointer = CLASS_DATA (c)->attr.class_pointer;
4574 24 : allocatable = CLASS_DATA (c)->attr.allocatable;
4575 : }
4576 : else
4577 : {
4578 433 : pointer = c->attr.pointer;
4579 433 : allocatable = c->attr.allocatable;
4580 : }
4581 : }
4582 :
4583 15729 : if (n->expr == NULL
4584 5807 : || (n->expr->ref->type == REF_ARRAY
4585 3677 : && n->expr->ref->u.ar.type == AR_FULL))
4586 : {
4587 9922 : gomp_map_kind map_kind;
4588 9922 : tree type = TREE_TYPE (decl);
4589 9922 : if (n->sym->ts.type == BT_CHARACTER
4590 218 : && n->sym->ts.deferred
4591 92 : && (n->sym->attr.omp_declare_target
4592 84 : || n->sym->attr.omp_declare_target_link
4593 84 : || n->sym->attr.omp_declare_target_local)
4594 8 : && (always_modifier || n->sym->attr.pointer)
4595 8 : && op != EXEC_OMP_TARGET_EXIT_DATA
4596 4 : && n->u.map.op != OMP_MAP_DELETE
4597 4 : && n->u.map.op != OMP_MAP_RELEASE)
4598 : {
4599 4 : gcc_assert (n->sym->ts.u.cl->backend_decl);
4600 4 : node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4601 4 : OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
4602 4 : OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
4603 4 : OMP_CLAUSE_SIZE (node5)
4604 8 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
4605 : }
4606 :
4607 9922 : tree present = gfc_omp_check_optional_argument (decl, true);
4608 9922 : if (openacc && n->sym->ts.type == BT_CLASS)
4609 : {
4610 60 : if (n->sym->attr.optional)
4611 0 : sorry_at (gfc_get_location (&n->where),
4612 : "optional class parameter");
4613 60 : tree ptr = gfc_class_data_get (decl);
4614 60 : ptr = build_fold_indirect_ref (ptr);
4615 60 : OMP_CLAUSE_DECL (node) = ptr;
4616 60 : OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
4617 60 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4618 60 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
4619 60 : OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
4620 60 : OMP_CLAUSE_SIZE (node2) = size_int (0);
4621 60 : goto finalize_map_clause;
4622 : }
4623 9862 : else if (POINTER_TYPE_P (type)
4624 9862 : && (gfc_omp_privatize_by_reference (decl)
4625 508 : || GFC_DECL_GET_SCALAR_POINTER (decl)
4626 323 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
4627 84 : || GFC_DECL_CRAY_POINTEE (decl)
4628 84 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
4629 84 : || (n->sym->ts.type == BT_DERIVED
4630 8 : && (n->sym->ts.u.derived->ts.f90_type
4631 : != BT_VOID))))
4632 : {
4633 3445 : tree orig_decl = decl;
4634 3445 : bool bare_attach_detach
4635 : = (openacc
4636 1252 : && (n->u.map.op == OMP_MAP_ATTACH
4637 1252 : || n->u.map.op == OMP_MAP_DETACH)
4638 4 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
4639 3449 : && !(POINTER_TYPE_P (TREE_TYPE (decl))
4640 4 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4641 3445 : (TREE_TYPE (decl)))));
4642 :
4643 : /* For nonallocatable, nonpointer arrays, a temporary
4644 : variable is generated, but this one is only defined if
4645 : the variable is present; hence, we now set it to NULL
4646 : to avoid accessing undefined variables. We cannot use
4647 : a temporary variable here as otherwise the replacement
4648 : of the variables in omp-low.cc will not work. */
4649 3445 : if (present && GFC_ARRAY_TYPE_P (type))
4650 : {
4651 284 : tree tmp = fold_build2_loc (input_location,
4652 : MODIFY_EXPR,
4653 : void_type_node, decl,
4654 : null_pointer_node);
4655 284 : tree cond = fold_build1_loc (input_location,
4656 : TRUTH_NOT_EXPR,
4657 : boolean_type_node,
4658 : present);
4659 284 : gfc_add_expr_to_block (&iter_block,
4660 : build3_loc (input_location,
4661 : COND_EXPR,
4662 : void_type_node,
4663 : cond, tmp,
4664 : NULL_TREE));
4665 : }
4666 : /* Bare OpenACC attach/detach on scalar pointer-like
4667 : variables wants a single attach operation on the
4668 : pointer itself, not a standalone pointer-mapping
4669 : node. Component and descriptor cases have dedicated
4670 : handling below; this covers the plain scalar path. */
4671 3445 : if (bare_attach_detach)
4672 : {
4673 4 : decl = build_fold_indirect_ref (decl);
4674 4 : OMP_CLAUSE_DECL (node) = build_fold_addr_expr (decl);
4675 4 : OMP_CLAUSE_SIZE (node) = size_zero_node;
4676 4 : goto finalize_map_clause;
4677 : }
4678 : /* For descriptor types, the unmapping happens below. */
4679 3441 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4680 3441 : || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4681 : {
4682 3441 : enum gomp_map_kind gmk = GOMP_MAP_POINTER;
4683 3441 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4684 73 : && n->u.map.op == OMP_MAP_DELETE)
4685 : gmk = GOMP_MAP_DELETE;
4686 62 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4687 62 : gmk = GOMP_MAP_RELEASE;
4688 3441 : tree size;
4689 3441 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4690 73 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4691 : else
4692 3368 : size = size_int (0);
4693 3441 : node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4694 3441 : OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
4695 3441 : OMP_CLAUSE_DECL (node4) = decl;
4696 3441 : OMP_CLAUSE_SIZE (node4) = size;
4697 : }
4698 3441 : decl = build_fold_indirect_ref (decl);
4699 3441 : if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
4700 2214 : || gfc_omp_is_optional_argument (orig_decl))
4701 4493 : && (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
4702 2109 : || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
4703 : {
4704 408 : enum gomp_map_kind gmk;
4705 408 : if (op == EXEC_OMP_TARGET_EXIT_DATA
4706 8 : && n->u.map.op == OMP_MAP_DELETE)
4707 : gmk = GOMP_MAP_DELETE;
4708 6 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
4709 : gmk = GOMP_MAP_RELEASE;
4710 : else
4711 : gmk = GOMP_MAP_POINTER;
4712 408 : tree size;
4713 408 : if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
4714 8 : size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
4715 : else
4716 400 : size = size_int (0);
4717 408 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4718 408 : OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
4719 408 : OMP_CLAUSE_DECL (node3) = decl;
4720 408 : OMP_CLAUSE_SIZE (node3) = size;
4721 408 : decl = build_fold_indirect_ref (decl);
4722 : }
4723 : }
4724 9858 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4725 : {
4726 1407 : tree type = TREE_TYPE (decl);
4727 1407 : tree ptr = gfc_conv_descriptor_data_get (decl);
4728 1407 : if (present)
4729 309 : ptr = gfc_build_cond_assign_expr (&iter_block,
4730 : present, ptr,
4731 : null_pointer_node);
4732 1407 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
4733 1407 : ptr = build_fold_indirect_ref (ptr);
4734 1407 : OMP_CLAUSE_DECL (node) = ptr;
4735 1407 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4736 1407 : OMP_CLAUSE_DECL (node2) = decl;
4737 1407 : OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
4738 1407 : if (n->u.map.op == OMP_MAP_DELETE)
4739 : map_kind = GOMP_MAP_DELETE;
4740 1380 : else if (op == EXEC_OMP_TARGET_EXIT_DATA
4741 1317 : || n->u.map.op == OMP_MAP_RELEASE)
4742 : map_kind = GOMP_MAP_RELEASE;
4743 : else
4744 1407 : map_kind = GOMP_MAP_TO_PSET;
4745 1407 : OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
4746 :
4747 1407 : if (op != EXEC_OMP_TARGET_EXIT_DATA
4748 1317 : && n->u.map.op != OMP_MAP_DELETE
4749 1317 : && n->u.map.op != OMP_MAP_RELEASE)
4750 : {
4751 1269 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
4752 1269 : if (present)
4753 : {
4754 309 : ptr = gfc_conv_descriptor_data_get (decl);
4755 309 : ptr = gfc_build_addr_expr (NULL, ptr);
4756 309 : ptr = gfc_build_cond_assign_expr (
4757 : &iter_block, present, ptr, null_pointer_node);
4758 309 : ptr = build_fold_indirect_ref (ptr);
4759 309 : OMP_CLAUSE_DECL (node3) = ptr;
4760 : }
4761 : else
4762 960 : OMP_CLAUSE_DECL (node3)
4763 1920 : = gfc_conv_descriptor_data_get (decl);
4764 1269 : OMP_CLAUSE_SIZE (node3) = size_int (0);
4765 :
4766 1269 : if (n->u.map.op == OMP_MAP_ATTACH)
4767 : {
4768 : /* Standalone attach clauses used with arrays with
4769 : descriptors must copy the descriptor to the
4770 : target, else they won't have anything to
4771 : perform the attachment onto (see OpenACC 2.6,
4772 : "2.6.3. Data Structures with Pointers"). */
4773 9 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
4774 : /* We don't want to map PTR at all in this case,
4775 : so delete its node and shuffle the others
4776 : down. */
4777 9 : node = node2;
4778 9 : node2 = node3;
4779 9 : node3 = NULL;
4780 9 : goto finalize_map_clause;
4781 : }
4782 1260 : else if (n->u.map.op == OMP_MAP_DETACH)
4783 : {
4784 4 : OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
4785 : /* Similarly to above, we don't want to unmap PTR
4786 : here. */
4787 4 : node = node2;
4788 4 : node2 = node3;
4789 4 : node3 = NULL;
4790 4 : goto finalize_map_clause;
4791 : }
4792 : else
4793 2042 : OMP_CLAUSE_SET_MAP_KIND (node3,
4794 : always_modifier
4795 : ? GOMP_MAP_ALWAYS_POINTER
4796 : : GOMP_MAP_POINTER);
4797 : }
4798 :
4799 : /* We have to check for n->sym->attr.dimension because
4800 : of scalar coarrays. */
4801 1394 : if ((n->sym->attr.pointer || n->sym->attr.allocatable)
4802 1394 : && n->sym->attr.dimension)
4803 : {
4804 1394 : stmtblock_t cond_block;
4805 1394 : tree size
4806 1394 : = gfc_create_var (gfc_array_index_type, NULL);
4807 1394 : tree tem, then_b, else_b, zero, cond;
4808 :
4809 1394 : gfc_init_block (&cond_block);
4810 1394 : tem
4811 2788 : = gfc_full_array_size (&cond_block, decl,
4812 1394 : GFC_TYPE_ARRAY_RANK (type));
4813 1394 : tree elemsz;
4814 1394 : if (n->sym->ts.type == BT_CHARACTER
4815 52 : && n->sym->ts.deferred)
4816 : {
4817 44 : tree len = n->sym->ts.u.cl->backend_decl;
4818 44 : len = fold_convert (size_type_node, len);
4819 44 : elemsz = gfc_get_char_type (n->sym->ts.kind);
4820 44 : elemsz = TYPE_SIZE_UNIT (elemsz);
4821 44 : elemsz = fold_build2 (MULT_EXPR, size_type_node,
4822 : len, elemsz);
4823 44 : }
4824 : else
4825 1350 : elemsz
4826 1350 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4827 1394 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4828 1394 : tem = fold_build2 (MULT_EXPR, gfc_array_index_type,
4829 : tem, elemsz);
4830 1394 : gfc_add_modify (&cond_block, size, tem);
4831 1394 : then_b = gfc_finish_block (&cond_block);
4832 1394 : gfc_init_block (&cond_block);
4833 1394 : zero = build_int_cst (gfc_array_index_type, 0);
4834 1394 : gfc_add_modify (&cond_block, size, zero);
4835 1394 : else_b = gfc_finish_block (&cond_block);
4836 1394 : tem = gfc_conv_descriptor_data_get (decl);
4837 1394 : tem = fold_convert (pvoid_type_node, tem);
4838 1394 : cond = fold_build2_loc (input_location, NE_EXPR,
4839 : boolean_type_node,
4840 : tem, null_pointer_node);
4841 1394 : if (present)
4842 309 : cond = fold_build2_loc (input_location,
4843 : TRUTH_ANDIF_EXPR,
4844 : boolean_type_node,
4845 : present, cond);
4846 1394 : gfc_add_expr_to_block (&iter_block,
4847 : build3_loc (input_location,
4848 : COND_EXPR,
4849 : void_type_node,
4850 : cond, then_b,
4851 : else_b));
4852 1394 : OMP_CLAUSE_SIZE (node) = size;
4853 1394 : }
4854 0 : else if (n->sym->attr.dimension)
4855 : {
4856 0 : stmtblock_t cond_block;
4857 0 : gfc_init_block (&cond_block);
4858 0 : tree size = gfc_full_array_size (&cond_block, decl,
4859 0 : GFC_TYPE_ARRAY_RANK (type));
4860 0 : tree elemsz
4861 0 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4862 0 : elemsz = fold_convert (gfc_array_index_type, elemsz);
4863 0 : size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4864 : size, elemsz);
4865 0 : size = gfc_evaluate_now (size, &cond_block);
4866 0 : if (present)
4867 : {
4868 0 : tree var = gfc_create_var (gfc_array_index_type,
4869 : NULL);
4870 0 : gfc_add_modify (&cond_block, var, size);
4871 0 : tree cond_body = gfc_finish_block (&cond_block);
4872 0 : tree cond = build3_loc (input_location, COND_EXPR,
4873 : void_type_node, present,
4874 : cond_body, NULL_TREE);
4875 0 : gfc_add_expr_to_block (&iter_block, cond);
4876 0 : OMP_CLAUSE_SIZE (node) = var;
4877 : }
4878 : else
4879 : {
4880 0 : gfc_add_block_to_block (&iter_block, &cond_block);
4881 0 : OMP_CLAUSE_SIZE (node) = size;
4882 : }
4883 : }
4884 : }
4885 8451 : else if (present
4886 845 : && INDIRECT_REF_P (decl)
4887 9194 : && INDIRECT_REF_P (TREE_OPERAND (decl, 0)))
4888 : {
4889 : /* A single indirectref is handled by the middle end. */
4890 228 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
4891 228 : tree tmp = TREE_OPERAND (decl, 0);
4892 228 : tmp = gfc_build_cond_assign_expr (&iter_block,
4893 : present, tmp,
4894 : null_pointer_node);
4895 228 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp);
4896 : }
4897 : else
4898 8223 : OMP_CLAUSE_DECL (node) = decl;
4899 :
4900 9845 : if (!n->sym->attr.dimension
4901 6148 : && n->sym->ts.type == BT_CHARACTER
4902 144 : && n->sym->ts.deferred)
4903 : {
4904 48 : if (!DECL_P (decl))
4905 : {
4906 48 : gcc_assert (TREE_CODE (decl) == INDIRECT_REF);
4907 48 : decl = TREE_OPERAND (decl, 0);
4908 : }
4909 48 : tree cond = fold_build2_loc (input_location, NE_EXPR,
4910 : boolean_type_node,
4911 : decl, null_pointer_node);
4912 48 : if (present)
4913 2 : cond = fold_build2_loc (input_location,
4914 : TRUTH_ANDIF_EXPR,
4915 : boolean_type_node,
4916 : present, cond);
4917 48 : tree len = n->sym->ts.u.cl->backend_decl;
4918 48 : len = fold_convert (size_type_node, len);
4919 48 : tree size = gfc_get_char_type (n->sym->ts.kind);
4920 48 : size = TYPE_SIZE_UNIT (size);
4921 48 : size = fold_build2 (MULT_EXPR, size_type_node, len, size);
4922 48 : size = build3_loc (input_location,
4923 : COND_EXPR,
4924 : size_type_node,
4925 : cond, size,
4926 : size_zero_node);
4927 48 : size = gfc_evaluate_now (size, &iter_block);
4928 48 : OMP_CLAUSE_SIZE (node) = size;
4929 : }
4930 9845 : if ((TREE_CODE (decl) != PARM_DECL
4931 186 : || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node)))
4932 9659 : && n->sym->ts.type == BT_DERIVED
4933 10389 : && n->sym->ts.u.derived->attr.alloc_comp)
4934 : {
4935 : /* Save array descriptor for use in
4936 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
4937 : to ensure that it is not gimplified + is a decl. */
4938 212 : tree tmp = OMP_CLAUSE_SIZE (node);
4939 212 : if (tmp == NULL_TREE)
4940 229 : tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
4941 46 : : TYPE_SIZE_UNIT (TREE_TYPE (decl));
4942 212 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
4943 212 : gfc_add_modify_loc (input_location, &iter_block,
4944 : var, tmp);
4945 212 : OMP_CLAUSE_SIZE (node) = var;
4946 212 : gfc_allocate_lang_decl (var);
4947 212 : if (TREE_CODE (decl) == INDIRECT_REF)
4948 48 : decl = TREE_OPERAND (decl, 0);
4949 212 : if (TREE_CODE (decl) == INDIRECT_REF)
4950 2 : decl = TREE_OPERAND (decl, 0);
4951 212 : if (DECL_LANG_SPECIFIC (decl)
4952 212 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
4953 6 : GFC_DECL_SAVED_DESCRIPTOR (var)
4954 2 : = GFC_DECL_SAVED_DESCRIPTOR (decl);
4955 : else
4956 210 : GFC_DECL_SAVED_DESCRIPTOR (var) = decl;
4957 : }
4958 : }
4959 5807 : else if (n->expr
4960 5807 : && n->expr->expr_type == EXPR_VARIABLE
4961 5807 : && n->expr->ref->type == REF_ARRAY
4962 3677 : && !n->expr->ref->next)
4963 : {
4964 : /* An array element or array section which is not part of a
4965 : derived type, etc. */
4966 3389 : bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
4967 3389 : tree type = TREE_TYPE (decl);
4968 3389 : gomp_map_kind k = GOMP_MAP_POINTER;
4969 3389 : if (!openacc
4970 538 : && !GFC_DESCRIPTOR_TYPE_P (type)
4971 3842 : && !(POINTER_TYPE_P (type)
4972 281 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
4973 : k = GOMP_MAP_FIRSTPRIVATE_POINTER;
4974 3389 : gfc_trans_omp_array_section (&iter_block, op, n, decl,
4975 3389 : element, !openacc, k,
4976 : node, node2, node3, node4,
4977 : iterator);
4978 3389 : }
4979 2418 : else if (n->expr
4980 2418 : && n->expr->expr_type == EXPR_VARIABLE
4981 2418 : && (n->expr->ref->type == REF_COMPONENT
4982 : || n->expr->ref->type == REF_ARRAY)
4983 2418 : && lastref
4984 2418 : && lastref->type == REF_COMPONENT
4985 457 : && lastref->u.c.component->ts.type != BT_CLASS
4986 433 : && lastref->u.c.component->ts.type != BT_DERIVED
4987 340 : && !lastref->u.c.component->attr.dimension)
4988 : {
4989 : /* Derived type access with last component being a scalar. */
4990 340 : gfc_init_se (&se, NULL);
4991 :
4992 340 : gfc_conv_expr (&se, n->expr);
4993 340 : gfc_add_block_to_block (&iter_block, &se.pre);
4994 : /* For BT_CHARACTER a pointer is returned. */
4995 340 : OMP_CLAUSE_DECL (node)
4996 586 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
4997 340 : ? build_fold_indirect_ref (se.expr) : se.expr;
4998 340 : gfc_add_block_to_block (&iter_block, &se.post);
4999 340 : if (pointer || allocatable)
5000 : {
5001 : /* If it's a bare attach/detach clause, we just want
5002 : to perform a single attach/detach operation, of the
5003 : pointer itself, not of the pointed-to object. */
5004 161 : if (openacc
5005 68 : && (n->u.map.op == OMP_MAP_ATTACH
5006 50 : || n->u.map.op == OMP_MAP_DETACH))
5007 : {
5008 36 : OMP_CLAUSE_DECL (node)
5009 36 : = build_fold_addr_expr (OMP_CLAUSE_DECL (node));
5010 36 : OMP_CLAUSE_SIZE (node) = size_zero_node;
5011 36 : goto finalize_map_clause;
5012 : }
5013 :
5014 125 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
5015 125 : OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
5016 125 : OMP_CLAUSE_DECL (node2)
5017 180 : = POINTER_TYPE_P (TREE_TYPE (se.expr))
5018 125 : ? se.expr
5019 55 : : gfc_build_addr_expr (NULL, se.expr);
5020 125 : OMP_CLAUSE_SIZE (node2) = size_int (0);
5021 125 : if (!openacc
5022 93 : && n->expr->ts.type == BT_CHARACTER
5023 54 : && n->expr->ts.deferred)
5024 : {
5025 54 : gcc_assert (se.string_length);
5026 54 : tree tmp
5027 54 : = gfc_get_char_type (n->expr->ts.kind);
5028 54 : OMP_CLAUSE_SIZE (node)
5029 54 : = fold_build2 (MULT_EXPR, size_type_node,
5030 : fold_convert (size_type_node,
5031 : se.string_length),
5032 : TYPE_SIZE_UNIT (tmp));
5033 54 : gomp_map_kind kind;
5034 54 : if (n->u.map.op == OMP_MAP_DELETE)
5035 : kind = GOMP_MAP_DELETE;
5036 54 : else if (op == EXEC_OMP_TARGET_EXIT_DATA)
5037 : kind = GOMP_MAP_RELEASE;
5038 : else
5039 48 : kind = GOMP_MAP_TO;
5040 54 : node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
5041 54 : OMP_CLAUSE_SET_MAP_KIND (node3, kind);
5042 54 : OMP_CLAUSE_DECL (node3) = se.string_length;
5043 54 : OMP_CLAUSE_SIZE (node3)
5044 108 : = TYPE_SIZE_UNIT (gfc_charlen_type_node);
5045 : }
5046 93 : if (!openacc
5047 93 : && n->expr->ts.type == BT_DERIVED
5048 0 : && n->expr->ts.u.derived->attr.alloc_comp)
5049 : {
5050 : /* Save array descriptor for use in
5051 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
5052 : to ensure that it is not gimplified + is a decl. */
5053 0 : tree tmp = OMP_CLAUSE_SIZE (node);
5054 0 : if (tmp == NULL_TREE)
5055 0 : tmp = (DECL_P (se.expr)
5056 0 : ? DECL_SIZE_UNIT (se.expr)
5057 0 : : TYPE_SIZE_UNIT (TREE_TYPE (se.expr)));
5058 0 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
5059 0 : gfc_add_modify_loc (input_location, &iter_block,
5060 : var, tmp);
5061 0 : OMP_CLAUSE_SIZE (node) = var;
5062 0 : gfc_allocate_lang_decl (var);
5063 0 : if (TREE_CODE (se.expr) == INDIRECT_REF)
5064 0 : se.expr = TREE_OPERAND (se.expr, 0);
5065 0 : if (DECL_LANG_SPECIFIC (se.expr)
5066 0 : && GFC_DECL_SAVED_DESCRIPTOR (se.expr))
5067 0 : GFC_DECL_SAVED_DESCRIPTOR (var)
5068 0 : = GFC_DECL_SAVED_DESCRIPTOR (se.expr);
5069 : else
5070 0 : GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
5071 : }
5072 : }
5073 : }
5074 2078 : else if (n->expr
5075 2078 : && n->expr->expr_type == EXPR_VARIABLE
5076 2078 : && (n->expr->ref->type == REF_COMPONENT
5077 : || n->expr->ref->type == REF_ARRAY))
5078 : {
5079 2078 : gfc_init_se (&se, NULL);
5080 2078 : se.expr = gfc_maybe_dereference_var (n->sym, decl);
5081 2078 : vec<tree> mid_descr = vNULL;
5082 2078 : vec<gfc_ref *> midref = vNULL;
5083 :
5084 7543 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
5085 : {
5086 5465 : if (ref->type == REF_COMPONENT)
5087 : {
5088 2739 : if (ref->u.c.sym->attr.extension)
5089 91 : conv_parent_component_references (&se, ref);
5090 :
5091 2739 : gfc_conv_component_ref (&se, ref);
5092 2739 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
5093 : {
5094 1999 : mid_descr.safe_push (se.expr);
5095 1999 : midref.safe_push (ref);
5096 : }
5097 : }
5098 2726 : else if (ref->type == REF_ARRAY)
5099 : {
5100 2726 : if (ref->u.ar.type == AR_ELEMENT && ref->next)
5101 765 : gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
5102 765 : &n->expr->where);
5103 : else
5104 1961 : gcc_assert (!ref->next);
5105 : }
5106 : else
5107 0 : sorry_at (gfc_get_location (&n->where),
5108 : "unhandled expression type");
5109 : }
5110 :
5111 2078 : tree inner = se.expr;
5112 :
5113 : /* Last component is a derived type or class pointer. */
5114 2078 : if (lastref->type == REF_COMPONENT
5115 117 : && (lastref->u.c.component->ts.type == BT_DERIVED
5116 24 : || lastref->u.c.component->ts.type == BT_CLASS))
5117 : {
5118 117 : if (pointer || allocatable)
5119 : {
5120 : /* If it's a bare attach/detach clause, we just want
5121 : to perform a single attach/detach operation, of the
5122 : pointer itself, not of the pointed-to object. */
5123 67 : if (openacc
5124 49 : && (n->u.map.op == OMP_MAP_ATTACH
5125 43 : || n->u.map.op == OMP_MAP_DETACH))
5126 : {
5127 12 : OMP_CLAUSE_DECL (node)
5128 12 : = build_fold_addr_expr (inner);
5129 12 : OMP_CLAUSE_SIZE (node) = size_zero_node;
5130 18 : goto finalize_map_clause;
5131 : }
5132 :
5133 18 : gfc_omp_namelist *n2
5134 : = openacc ? NULL : clauses->lists[OMP_LIST_MAP];
5135 :
5136 55 : bool sym_based;
5137 55 : n2 = get_symbol_rooted_namelist (sym_rooted_nl, n,
5138 : n2, &sym_based);
5139 :
5140 : /* If the last reference is a pointer to a derived
5141 : type ("foo%dt_ptr"), check if any subcomponents
5142 : of the same derived type member are being mapped
5143 : elsewhere in the clause list ("foo%dt_ptr%x",
5144 : etc.). If we have such subcomponent mappings,
5145 : we only create an ALLOC node for the pointer
5146 : itself, and inhibit mapping the whole derived
5147 : type. */
5148 :
5149 103 : for (; n2 != NULL; n2 = n2->next)
5150 : {
5151 54 : if ((!sym_based && n == n2)
5152 54 : || (sym_based && n == n2->u2.duplicate_of)
5153 42 : || !n2->expr)
5154 12 : continue;
5155 :
5156 42 : if (!gfc_omp_expr_prefix_same (n->expr,
5157 : n2->expr))
5158 36 : continue;
5159 :
5160 6 : gfc_ref *ref1 = n->expr->ref;
5161 6 : gfc_ref *ref2 = n2->expr->ref;
5162 :
5163 6 : while (ref1->next && ref2->next)
5164 : {
5165 : ref1 = ref1->next;
5166 : ref2 = ref2->next;
5167 : }
5168 :
5169 6 : if (ref2->next)
5170 : {
5171 6 : inner = build_fold_addr_expr (inner);
5172 6 : OMP_CLAUSE_SET_MAP_KIND (node,
5173 : GOMP_MAP_ALLOC);
5174 6 : OMP_CLAUSE_DECL (node) = inner;
5175 6 : OMP_CLAUSE_SIZE (node)
5176 6 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5177 6 : goto finalize_map_clause;
5178 : }
5179 : }
5180 :
5181 49 : tree data, size;
5182 :
5183 49 : if (lastref->u.c.component->ts.type == BT_CLASS)
5184 : {
5185 24 : data = gfc_class_data_get (inner);
5186 24 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
5187 24 : data = build_fold_indirect_ref (data);
5188 24 : size = gfc_class_vtab_size_get (inner);
5189 : }
5190 : else /* BT_DERIVED. */
5191 : {
5192 25 : data = inner;
5193 25 : size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5194 : }
5195 :
5196 49 : OMP_CLAUSE_DECL (node) = data;
5197 49 : OMP_CLAUSE_SIZE (node) = size;
5198 49 : node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
5199 49 : OMP_CLAUSE_SET_MAP_KIND (node2,
5200 : GOMP_MAP_ATTACH_DETACH);
5201 49 : OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
5202 49 : OMP_CLAUSE_SIZE (node2) = size_int (0);
5203 : }
5204 : else
5205 : {
5206 50 : OMP_CLAUSE_DECL (node) = inner;
5207 50 : OMP_CLAUSE_SIZE (node)
5208 100 : = TYPE_SIZE_UNIT (TREE_TYPE (inner));
5209 : }
5210 99 : if (!openacc
5211 15 : && n->expr->ts.type == BT_DERIVED
5212 15 : && n->expr->ts.u.derived->attr.alloc_comp)
5213 : {
5214 : /* Save array descriptor for use in
5215 : gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
5216 : to ensure that it is not gimplified + is a decl. */
5217 8 : tree tmp = OMP_CLAUSE_SIZE (node);
5218 8 : tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
5219 8 : gfc_add_modify_loc (input_location, &iter_block,
5220 : var, tmp);
5221 8 : OMP_CLAUSE_SIZE (node) = var;
5222 8 : gfc_allocate_lang_decl (var);
5223 8 : if (TREE_CODE (inner) == INDIRECT_REF)
5224 6 : inner = TREE_OPERAND (inner, 0);
5225 8 : GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
5226 : }
5227 : }
5228 1961 : else if (lastref->type == REF_ARRAY
5229 1961 : && lastref->u.ar.type == AR_FULL)
5230 : {
5231 : /* Bare attach and detach clauses don't want any
5232 : additional nodes. */
5233 1234 : if ((n->u.map.op == OMP_MAP_ATTACH
5234 1203 : || n->u.map.op == OMP_MAP_DETACH)
5235 1248 : && (POINTER_TYPE_P (TREE_TYPE (inner))
5236 45 : || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))))
5237 : {
5238 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
5239 : {
5240 45 : tree ptr = gfc_conv_descriptor_data_get (inner);
5241 45 : OMP_CLAUSE_DECL (node) = ptr;
5242 : }
5243 : else
5244 0 : OMP_CLAUSE_DECL (node) = inner;
5245 45 : OMP_CLAUSE_SIZE (node) = size_zero_node;
5246 45 : goto finalize_map_clause;
5247 : }
5248 :
5249 1189 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
5250 : {
5251 1019 : bool drop_mapping = gfc_map_array_descriptor (
5252 : node, node2, node3, node4, inner, openacc, map_loc,
5253 : &iter_block, op, n, sym_rooted_nl, se, clauses,
5254 : false);
5255 1019 : if (drop_mapping)
5256 286 : continue;
5257 : }
5258 : else
5259 170 : OMP_CLAUSE_DECL (node) = inner;
5260 : }
5261 727 : else if (lastref->type == REF_ARRAY)
5262 : {
5263 : /* An array element or section. */
5264 727 : bool element = lastref->u.ar.type == AR_ELEMENT;
5265 727 : gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH;
5266 727 : gfc_trans_omp_array_section (&iter_block, op, n, inner,
5267 727 : element, !openacc, kind,
5268 : node, node2, node3, node4,
5269 : iterator);
5270 : }
5271 : else
5272 0 : gcc_unreachable ();
5273 :
5274 : /* Map intermediate array descriptors. */
5275 1645 : if (!openacc && !mid_descr.is_empty ())
5276 2321 : for (size_t i = 0; i < mid_descr.length (); i++)
5277 1333 : if (mid_descr[i] != inner
5278 1333 : && !descriptors.contains (midref[i]->u.c.sym))
5279 : {
5280 172 : descriptors.safe_push (midref[i]->u.c.sym);
5281 172 : tree node1 = copy_node (node);
5282 172 : tree node2 = NULL_TREE;
5283 172 : tree node3 = NULL_TREE;
5284 172 : tree node4 = NULL_TREE;
5285 344 : gfc_map_array_descriptor (node1, node2, node3, node4,
5286 172 : mid_descr[i], openacc,
5287 : map_loc, &iter_block,
5288 : op, n,
5289 : sym_rooted_nl, se, clauses,
5290 : true);
5291 :
5292 172 : if (node1 != NULL_TREE)
5293 90 : omp_clauses
5294 90 : = gfc_trans_add_clause (node1, omp_clauses);
5295 172 : if (node2 != NULL_TREE)
5296 172 : omp_clauses
5297 172 : = gfc_trans_add_clause (node2, omp_clauses);
5298 172 : if (node3 != NULL_TREE)
5299 172 : omp_clauses
5300 172 : = gfc_trans_add_clause (node3, omp_clauses);
5301 172 : if (node4 != NULL_TREE)
5302 0 : omp_clauses
5303 0 : = gfc_trans_add_clause (node4, omp_clauses);
5304 : }
5305 1729 : }
5306 : else
5307 0 : sorry_at (gfc_get_location (&n->where), "unhandled expression");
5308 :
5309 15443 : finalize_map_clause:
5310 :
5311 15443 : if (!iterator)
5312 15404 : gfc_add_block_to_block (block, &iter_block);
5313 :
5314 15443 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5315 15443 : if (node2)
5316 5153 : omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
5317 15443 : if (node3)
5318 6422 : omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
5319 15443 : if (node4)
5320 3562 : omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
5321 15443 : if (node5)
5322 4 : omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
5323 : }
5324 9196 : if (iterator)
5325 : {
5326 : /* Finish last iterator group. */
5327 12 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
5328 12 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
5329 86 : for (tree c = omp_clauses; c != prev_clauses;
5330 37 : c = OMP_CLAUSE_CHAIN (c))
5331 37 : if (OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_FIRSTPRIVATE_POINTER
5332 37 : && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_FIRSTPRIVATE_REFERENCE)
5333 33 : OMP_CLAUSE_ITERATORS (c) = iterator;
5334 : }
5335 : break;
5336 : case OMP_LIST_TO:
5337 : case OMP_LIST_FROM:
5338 : case OMP_LIST_CACHE:
5339 : iterator = NULL_TREE;
5340 : prev = NULL;
5341 : prev_clauses = omp_clauses;
5342 3662 : for (; n != NULL; n = n->next)
5343 : {
5344 1876 : if (!n->sym->attr.referenced
5345 0 : && n->sym->attr.flavor != FL_PARAMETER)
5346 0 : continue;
5347 :
5348 1876 : if (iterator && prev->u2.ns != n->u2.ns)
5349 : {
5350 : /* Finish previous iterator group. */
5351 0 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
5352 0 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
5353 0 : for (tree c = omp_clauses; c != prev_clauses;
5354 0 : c = OMP_CLAUSE_CHAIN (c))
5355 0 : OMP_CLAUSE_ITERATORS (c) = iterator;
5356 : prev_clauses = omp_clauses;
5357 : iterator = NULL_TREE;
5358 : }
5359 1876 : if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
5360 : {
5361 : /* Start a new iterator group. */
5362 11 : gfc_init_block (&iter_block);
5363 11 : tree_block = make_node (BLOCK);
5364 11 : TREE_USED (tree_block) = 1;
5365 11 : BLOCK_VARS (tree_block) = NULL_TREE;
5366 11 : prev_clauses = omp_clauses;
5367 11 : iterator = handle_iterator (n->u2.ns, block, tree_block);
5368 : }
5369 1876 : if (!iterator)
5370 1862 : gfc_init_block (&iter_block);
5371 1876 : prev = n;
5372 :
5373 1876 : switch (list)
5374 : {
5375 : case OMP_LIST_TO:
5376 : clause_code = OMP_CLAUSE_TO;
5377 : break;
5378 1032 : case OMP_LIST_FROM:
5379 1032 : clause_code = OMP_CLAUSE_FROM;
5380 1032 : break;
5381 84 : case OMP_LIST_CACHE:
5382 84 : clause_code = OMP_CLAUSE__CACHE_;
5383 84 : break;
5384 0 : default:
5385 0 : gcc_unreachable ();
5386 : }
5387 1876 : tree node = build_omp_clause (gfc_get_location (&n->where),
5388 : clause_code);
5389 1876 : if (n->expr == NULL
5390 141 : || (n->expr->ref->type == REF_ARRAY
5391 129 : && n->expr->ref->u.ar.type == AR_FULL
5392 0 : && n->expr->ref->next == NULL))
5393 : {
5394 1735 : tree decl = gfc_trans_omp_variable (n->sym, false);
5395 1735 : if (gfc_omp_privatize_by_reference (decl))
5396 : {
5397 1047 : if (gfc_omp_is_allocatable_or_ptr (decl))
5398 240 : decl = build_fold_indirect_ref (decl);
5399 1047 : decl = build_fold_indirect_ref (decl);
5400 : }
5401 688 : else if (DECL_P (decl))
5402 688 : TREE_ADDRESSABLE (decl) = 1;
5403 1735 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5404 : {
5405 597 : tree type = TREE_TYPE (decl);
5406 597 : tree ptr = gfc_conv_descriptor_data_get (decl);
5407 597 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5408 597 : ptr = build_fold_indirect_ref (ptr);
5409 597 : OMP_CLAUSE_DECL (node) = ptr;
5410 597 : OMP_CLAUSE_SIZE (node)
5411 597 : = gfc_full_array_size (&iter_block, decl,
5412 597 : GFC_TYPE_ARRAY_RANK (type));
5413 597 : tree elemsz
5414 597 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5415 597 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5416 1194 : OMP_CLAUSE_SIZE (node)
5417 1194 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5418 : OMP_CLAUSE_SIZE (node), elemsz);
5419 : }
5420 : else
5421 : {
5422 1138 : OMP_CLAUSE_DECL (node) = decl;
5423 1138 : if (gfc_omp_is_allocatable_or_ptr (decl))
5424 120 : OMP_CLAUSE_SIZE (node)
5425 240 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
5426 : }
5427 : }
5428 : else
5429 : {
5430 141 : tree ptr;
5431 141 : gfc_init_se (&se, NULL);
5432 141 : if (n->expr->rank == 0)
5433 : {
5434 9 : gfc_conv_expr_reference (&se, n->expr);
5435 9 : ptr = se.expr;
5436 9 : gfc_add_block_to_block (&iter_block, &se.pre);
5437 9 : OMP_CLAUSE_SIZE (node)
5438 18 : = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr)));
5439 : }
5440 : else
5441 : {
5442 132 : gfc_conv_expr_descriptor (&se, n->expr);
5443 132 : ptr = gfc_conv_array_data (se.expr);
5444 132 : tree type = TREE_TYPE (se.expr);
5445 132 : gfc_add_block_to_block (&iter_block, &se.pre);
5446 132 : OMP_CLAUSE_SIZE (node)
5447 132 : = gfc_full_array_size (&iter_block, se.expr,
5448 132 : GFC_TYPE_ARRAY_RANK (type));
5449 132 : tree elemsz
5450 132 : = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5451 132 : elemsz = fold_convert (gfc_array_index_type, elemsz);
5452 264 : OMP_CLAUSE_SIZE (node)
5453 264 : = fold_build2 (MULT_EXPR, gfc_array_index_type,
5454 : OMP_CLAUSE_SIZE (node), elemsz);
5455 : }
5456 141 : gfc_add_block_to_block (&iter_block, &se.post);
5457 141 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
5458 141 : OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
5459 : }
5460 1876 : if (n->u.present_modifier)
5461 5 : OMP_CLAUSE_MOTION_PRESENT (node) = 1;
5462 1876 : if (list == OMP_LIST_CACHE && n->u.map.readonly)
5463 16 : OMP_CLAUSE__CACHE__READONLY (node) = 1;
5464 1876 : if (!iterator)
5465 1862 : gfc_add_block_to_block (block, &iter_block);
5466 1876 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5467 : }
5468 1786 : if (iterator)
5469 : {
5470 : /* Finish last iterator group. */
5471 11 : BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
5472 11 : OMP_ITERATOR_BLOCK (iterator) = tree_block;
5473 25 : for (tree c = omp_clauses; c != prev_clauses;
5474 14 : c = OMP_CLAUSE_CHAIN (c))
5475 14 : OMP_CLAUSE_ITERATORS (c) = iterator;
5476 : }
5477 : break;
5478 : case OMP_LIST_USES_ALLOCATORS:
5479 90 : for (; n != NULL; n = n->next)
5480 : {
5481 61 : if (!n->sym->attr.referenced)
5482 48 : continue;
5483 13 : tree node = build_omp_clause (input_location,
5484 : OMP_CLAUSE_USES_ALLOCATORS);
5485 13 : tree t;
5486 13 : if (n->sym->attr.flavor == FL_VARIABLE)
5487 12 : t = gfc_get_symbol_decl (n->sym);
5488 : else
5489 : {
5490 1 : t = gfc_conv_mpz_to_tree (n->sym->value->value.integer,
5491 : n->sym->ts.kind);
5492 1 : t = fold_convert (ptr_type_node, t);
5493 : }
5494 13 : OMP_CLAUSE_USES_ALLOCATORS_ALLOCATOR(node) = t;
5495 13 : if (n->u.memspace_sym)
5496 : {
5497 3 : n->u.memspace_sym->attr.referenced = true;
5498 3 : OMP_CLAUSE_USES_ALLOCATORS_MEMSPACE (node)
5499 6 : = gfc_get_symbol_decl (n->u.memspace_sym);
5500 : }
5501 13 : if (n->u2.traits_sym)
5502 : {
5503 7 : n->u2.traits_sym->attr.referenced = true;
5504 7 : OMP_CLAUSE_USES_ALLOCATORS_TRAITS (node)
5505 14 : = gfc_get_symbol_decl (n->u2.traits_sym);
5506 : }
5507 13 : omp_clauses = gfc_trans_add_clause (node, omp_clauses);
5508 : }
5509 : break;
5510 : default:
5511 : break;
5512 : }
5513 : }
5514 :
5515 : /* Free hashmap if we built it. */
5516 31956 : if (sym_rooted_nl)
5517 : {
5518 388 : typedef hash_map<gfc_symbol *, gfc_omp_namelist *>::iterator hti;
5519 1278 : for (hti it = sym_rooted_nl->begin (); it != sym_rooted_nl->end (); ++it)
5520 : {
5521 445 : gfc_omp_namelist *&nl = (*it).second;
5522 1771 : while (nl)
5523 : {
5524 1326 : gfc_omp_namelist *next = nl->next;
5525 1326 : free (nl);
5526 1326 : nl = next;
5527 : }
5528 : }
5529 388 : delete sym_rooted_nl;
5530 : }
5531 :
5532 31956 : if (clauses->if_expr)
5533 : {
5534 1112 : tree if_var;
5535 :
5536 1112 : gfc_init_se (&se, NULL);
5537 1112 : gfc_conv_expr (&se, clauses->if_expr);
5538 1112 : gfc_add_block_to_block (block, &se.pre);
5539 1112 : if_var = gfc_evaluate_now (se.expr, block);
5540 1112 : gfc_add_block_to_block (block, &se.post);
5541 :
5542 1112 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5543 1112 : OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK;
5544 1112 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5545 1112 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5546 : }
5547 :
5548 351516 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
5549 319560 : if (clauses->if_exprs[ifc])
5550 : {
5551 123 : tree if_var;
5552 :
5553 123 : gfc_init_se (&se, NULL);
5554 123 : gfc_conv_expr (&se, clauses->if_exprs[ifc]);
5555 123 : gfc_add_block_to_block (block, &se.pre);
5556 123 : if_var = gfc_evaluate_now (se.expr, block);
5557 123 : gfc_add_block_to_block (block, &se.post);
5558 :
5559 123 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
5560 123 : switch (ifc)
5561 : {
5562 0 : case OMP_IF_CANCEL:
5563 0 : OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
5564 0 : break;
5565 40 : case OMP_IF_PARALLEL:
5566 40 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
5567 40 : break;
5568 39 : case OMP_IF_SIMD:
5569 39 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
5570 39 : break;
5571 1 : case OMP_IF_TASK:
5572 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
5573 1 : break;
5574 23 : case OMP_IF_TASKLOOP:
5575 23 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
5576 23 : break;
5577 16 : case OMP_IF_TARGET:
5578 16 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
5579 16 : break;
5580 1 : case OMP_IF_TARGET_DATA:
5581 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
5582 1 : break;
5583 1 : case OMP_IF_TARGET_UPDATE:
5584 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
5585 1 : break;
5586 1 : case OMP_IF_TARGET_ENTER_DATA:
5587 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
5588 1 : break;
5589 1 : case OMP_IF_TARGET_EXIT_DATA:
5590 1 : OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
5591 1 : break;
5592 : default:
5593 : gcc_unreachable ();
5594 : }
5595 123 : OMP_CLAUSE_IF_EXPR (c) = if_var;
5596 123 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5597 : }
5598 :
5599 31956 : if (clauses->self_expr)
5600 : {
5601 159 : tree self_var;
5602 :
5603 159 : gfc_init_se (&se, NULL);
5604 159 : gfc_conv_expr (&se, clauses->self_expr);
5605 159 : gfc_add_block_to_block (block, &se.pre);
5606 159 : self_var = gfc_evaluate_now (se.expr, block);
5607 159 : gfc_add_block_to_block (block, &se.post);
5608 :
5609 159 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SELF);
5610 159 : OMP_CLAUSE_SELF_EXPR (c) = self_var;
5611 159 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5612 : }
5613 :
5614 31956 : if (clauses->final_expr)
5615 : {
5616 64 : tree final_var;
5617 :
5618 64 : gfc_init_se (&se, NULL);
5619 64 : gfc_conv_expr (&se, clauses->final_expr);
5620 64 : gfc_add_block_to_block (block, &se.pre);
5621 64 : final_var = gfc_evaluate_now (se.expr, block);
5622 64 : gfc_add_block_to_block (block, &se.post);
5623 :
5624 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
5625 64 : OMP_CLAUSE_FINAL_EXPR (c) = final_var;
5626 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5627 : }
5628 :
5629 31956 : if (clauses->novariants)
5630 : {
5631 8 : tree novariants_var;
5632 :
5633 8 : gfc_init_se (&se, NULL);
5634 8 : gfc_conv_expr (&se, clauses->novariants);
5635 8 : gfc_add_block_to_block (block, &se.pre);
5636 8 : novariants_var = gfc_evaluate_now (se.expr, block);
5637 8 : gfc_add_block_to_block (block, &se.post);
5638 :
5639 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
5640 8 : OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
5641 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5642 : }
5643 :
5644 31956 : if (clauses->nocontext)
5645 : {
5646 9 : tree nocontext_var;
5647 :
5648 9 : gfc_init_se (&se, NULL);
5649 9 : gfc_conv_expr (&se, clauses->nocontext);
5650 9 : gfc_add_block_to_block (block, &se.pre);
5651 9 : nocontext_var = gfc_evaluate_now (se.expr, block);
5652 9 : gfc_add_block_to_block (block, &se.post);
5653 :
5654 9 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
5655 9 : OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
5656 9 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5657 : }
5658 :
5659 31956 : if (clauses->num_threads)
5660 : {
5661 945 : tree num_threads;
5662 :
5663 945 : gfc_init_se (&se, NULL);
5664 945 : gfc_conv_expr (&se, clauses->num_threads);
5665 945 : gfc_add_block_to_block (block, &se.pre);
5666 945 : num_threads = gfc_evaluate_now (se.expr, block);
5667 945 : gfc_add_block_to_block (block, &se.post);
5668 :
5669 945 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS);
5670 945 : OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
5671 945 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5672 : }
5673 :
5674 31956 : if (clauses->device_type != OMP_DEVICE_TYPE_UNSET)
5675 : {
5676 3 : enum omp_clause_device_type_kind type;
5677 3 : switch (clauses->device_type)
5678 : {
5679 : case OMP_DEVICE_TYPE_HOST:
5680 : type = OMP_CLAUSE_DEVICE_TYPE_HOST;
5681 : break;
5682 : case OMP_DEVICE_TYPE_NOHOST:
5683 : type = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
5684 : break;
5685 : case OMP_DEVICE_TYPE_ANY:
5686 : type = OMP_CLAUSE_DEVICE_TYPE_ANY;
5687 : break;
5688 0 : case OMP_DEVICE_TYPE_UNSET:
5689 0 : default:
5690 0 : gcc_unreachable ();
5691 : }
5692 3 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE_TYPE);
5693 3 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = type;
5694 3 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5695 : }
5696 :
5697 31956 : if (clauses->dyn_groupprivate)
5698 : {
5699 5 : gfc_init_se (&se, NULL);
5700 5 : gfc_conv_expr (&se, clauses->dyn_groupprivate);
5701 5 : gfc_add_block_to_block (block, &se.pre);
5702 5 : tree expr = (CONSTANT_CLASS_P (se.expr) || DECL_P (se.expr)
5703 5 : ? se.expr : gfc_evaluate_now (se.expr, block));
5704 5 : gfc_add_block_to_block (block, &se.post);
5705 :
5706 5 : enum omp_clause_fallback_kind kind = OMP_CLAUSE_FALLBACK_UNSPECIFIED;
5707 5 : switch (clauses->fallback)
5708 : {
5709 : case OMP_FALLBACK_ABORT:
5710 : kind = OMP_CLAUSE_FALLBACK_ABORT;
5711 : break;
5712 : case OMP_FALLBACK_DEFAULT_MEM:
5713 : kind = OMP_CLAUSE_FALLBACK_DEFAULT_MEM;
5714 : break;
5715 : case OMP_FALLBACK_NULL:
5716 : kind = OMP_CLAUSE_FALLBACK_NULL;
5717 : break;
5718 : case OMP_FALLBACK_NONE:
5719 : break;
5720 : }
5721 5 : c = build_omp_clause (gfc_get_location (&where),
5722 : OMP_CLAUSE_DYN_GROUPPRIVATE);
5723 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_KIND (c) = kind;
5724 5 : OMP_CLAUSE_DYN_GROUPPRIVATE_EXPR (c) = expr;
5725 5 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5726 : }
5727 :
5728 31956 : chunk_size = NULL_TREE;
5729 31956 : if (clauses->chunk_size)
5730 : {
5731 487 : gfc_init_se (&se, NULL);
5732 487 : gfc_conv_expr (&se, clauses->chunk_size);
5733 487 : gfc_add_block_to_block (block, &se.pre);
5734 487 : chunk_size = gfc_evaluate_now (se.expr, block);
5735 487 : gfc_add_block_to_block (block, &se.post);
5736 : }
5737 :
5738 31956 : if (clauses->sched_kind != OMP_SCHED_NONE)
5739 : {
5740 770 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
5741 770 : OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
5742 770 : switch (clauses->sched_kind)
5743 : {
5744 401 : case OMP_SCHED_STATIC:
5745 401 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
5746 401 : break;
5747 153 : case OMP_SCHED_DYNAMIC:
5748 153 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
5749 153 : break;
5750 125 : case OMP_SCHED_GUIDED:
5751 125 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
5752 125 : break;
5753 84 : case OMP_SCHED_RUNTIME:
5754 84 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
5755 84 : break;
5756 7 : case OMP_SCHED_AUTO:
5757 7 : OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
5758 7 : break;
5759 0 : default:
5760 0 : gcc_unreachable ();
5761 : }
5762 770 : if (clauses->sched_monotonic)
5763 54 : OMP_CLAUSE_SCHEDULE_KIND (c)
5764 27 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5765 : | OMP_CLAUSE_SCHEDULE_MONOTONIC);
5766 743 : else if (clauses->sched_nonmonotonic)
5767 46 : OMP_CLAUSE_SCHEDULE_KIND (c)
5768 23 : = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
5769 : | OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
5770 770 : if (clauses->sched_simd)
5771 17 : OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
5772 770 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5773 : }
5774 :
5775 31956 : if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
5776 : {
5777 1081 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
5778 1081 : switch (clauses->default_sharing)
5779 : {
5780 677 : case OMP_DEFAULT_NONE:
5781 677 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
5782 677 : break;
5783 183 : case OMP_DEFAULT_SHARED:
5784 183 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
5785 183 : break;
5786 24 : case OMP_DEFAULT_PRIVATE:
5787 24 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
5788 24 : break;
5789 2 : case OMP_DEFAULT_FIRSTPRIVATE:
5790 2 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
5791 2 : break;
5792 195 : case OMP_DEFAULT_PRESENT:
5793 195 : OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
5794 195 : break;
5795 0 : default:
5796 0 : gcc_unreachable ();
5797 : }
5798 1081 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5799 : }
5800 :
5801 31956 : if (clauses->nowait)
5802 : {
5803 2061 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT);
5804 2061 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5805 : }
5806 :
5807 31956 : if (clauses->full)
5808 : {
5809 47 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FULL);
5810 47 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5811 : }
5812 :
5813 31956 : if (clauses->partial)
5814 : {
5815 259 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARTIAL);
5816 259 : OMP_CLAUSE_PARTIAL_EXPR (c)
5817 518 : = (clauses->partial > 0
5818 259 : ? build_int_cst (integer_type_node, clauses->partial)
5819 : : NULL_TREE);
5820 259 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5821 : }
5822 :
5823 31956 : if (clauses->sizes_list)
5824 : {
5825 : tree list = NULL_TREE;
5826 344 : for (gfc_expr_list *el = clauses->sizes_list; el; el = el->next)
5827 224 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
5828 : list);
5829 :
5830 120 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIZES);
5831 120 : OMP_CLAUSE_SIZES_LIST (c) = nreverse (list);
5832 120 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5833 : }
5834 :
5835 31956 : if (clauses->ordered)
5836 : {
5837 315 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
5838 315 : OMP_CLAUSE_ORDERED_EXPR (c)
5839 315 : = clauses->orderedc ? build_int_cst (integer_type_node,
5840 134 : clauses->orderedc) : NULL_TREE;
5841 315 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5842 : }
5843 :
5844 31956 : if (clauses->order_concurrent)
5845 : {
5846 303 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
5847 303 : OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
5848 303 : OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
5849 303 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5850 : }
5851 :
5852 31956 : if (clauses->untied)
5853 : {
5854 141 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED);
5855 141 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5856 : }
5857 :
5858 31956 : if (clauses->mergeable)
5859 : {
5860 32 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
5861 32 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5862 : }
5863 :
5864 31956 : if (clauses->collapse)
5865 : {
5866 1628 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE);
5867 1628 : OMP_CLAUSE_COLLAPSE_EXPR (c)
5868 1628 : = build_int_cst (integer_type_node, clauses->collapse);
5869 1628 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5870 : }
5871 :
5872 31956 : if (clauses->inbranch)
5873 : {
5874 18 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH);
5875 18 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5876 : }
5877 :
5878 31956 : if (clauses->notinbranch)
5879 : {
5880 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH);
5881 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5882 : }
5883 :
5884 31956 : switch (clauses->cancel)
5885 : {
5886 : case OMP_CANCEL_UNKNOWN:
5887 : break;
5888 0 : case OMP_CANCEL_PARALLEL:
5889 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL);
5890 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5891 0 : break;
5892 0 : case OMP_CANCEL_SECTIONS:
5893 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS);
5894 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5895 0 : break;
5896 0 : case OMP_CANCEL_DO:
5897 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR);
5898 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5899 0 : break;
5900 0 : case OMP_CANCEL_TASKGROUP:
5901 0 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP);
5902 0 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5903 0 : break;
5904 : }
5905 :
5906 31956 : if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
5907 : {
5908 64 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
5909 64 : switch (clauses->proc_bind)
5910 : {
5911 1 : case OMP_PROC_BIND_PRIMARY:
5912 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
5913 1 : break;
5914 9 : case OMP_PROC_BIND_MASTER:
5915 9 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
5916 9 : break;
5917 53 : case OMP_PROC_BIND_SPREAD:
5918 53 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
5919 53 : break;
5920 1 : case OMP_PROC_BIND_CLOSE:
5921 1 : OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
5922 1 : break;
5923 0 : default:
5924 0 : gcc_unreachable ();
5925 : }
5926 64 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5927 : }
5928 :
5929 31956 : if (clauses->safelen_expr)
5930 : {
5931 89 : tree safelen_var;
5932 :
5933 89 : gfc_init_se (&se, NULL);
5934 89 : gfc_conv_expr (&se, clauses->safelen_expr);
5935 89 : gfc_add_block_to_block (block, &se.pre);
5936 89 : safelen_var = gfc_evaluate_now (se.expr, block);
5937 89 : gfc_add_block_to_block (block, &se.post);
5938 :
5939 89 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
5940 89 : OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
5941 89 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5942 : }
5943 :
5944 31956 : if (clauses->simdlen_expr)
5945 : {
5946 110 : if (declare_simd)
5947 : {
5948 65 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5949 65 : OMP_CLAUSE_SIMDLEN_EXPR (c)
5950 65 : = gfc_conv_constant_to_tree (clauses->simdlen_expr);
5951 65 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5952 : }
5953 : else
5954 : {
5955 45 : tree simdlen_var;
5956 :
5957 45 : gfc_init_se (&se, NULL);
5958 45 : gfc_conv_expr (&se, clauses->simdlen_expr);
5959 45 : gfc_add_block_to_block (block, &se.pre);
5960 45 : simdlen_var = gfc_evaluate_now (se.expr, block);
5961 45 : gfc_add_block_to_block (block, &se.post);
5962 :
5963 45 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN);
5964 45 : OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var;
5965 45 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5966 : }
5967 : }
5968 :
5969 31956 : if (clauses->num_teams_upper)
5970 : {
5971 113 : tree num_teams_lower = NULL_TREE, num_teams_upper;
5972 :
5973 113 : gfc_init_se (&se, NULL);
5974 113 : gfc_conv_expr (&se, clauses->num_teams_upper);
5975 113 : gfc_add_block_to_block (block, &se.pre);
5976 113 : num_teams_upper = gfc_evaluate_now (se.expr, block);
5977 113 : gfc_add_block_to_block (block, &se.post);
5978 :
5979 113 : if (clauses->num_teams_lower)
5980 : {
5981 21 : gfc_init_se (&se, NULL);
5982 21 : gfc_conv_expr (&se, clauses->num_teams_lower);
5983 21 : gfc_add_block_to_block (block, &se.pre);
5984 21 : num_teams_lower = gfc_evaluate_now (se.expr, block);
5985 21 : gfc_add_block_to_block (block, &se.post);
5986 : }
5987 113 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
5988 113 : OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
5989 113 : OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
5990 113 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
5991 : }
5992 :
5993 31956 : if (clauses->device)
5994 : {
5995 297 : tree device;
5996 :
5997 297 : gfc_init_se (&se, NULL);
5998 297 : gfc_conv_expr (&se, clauses->device);
5999 297 : gfc_add_block_to_block (block, &se.pre);
6000 297 : device = gfc_evaluate_now (se.expr, block);
6001 297 : gfc_add_block_to_block (block, &se.post);
6002 :
6003 297 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
6004 297 : OMP_CLAUSE_DEVICE_ID (c) = device;
6005 :
6006 297 : if (clauses->ancestor)
6007 39 : OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
6008 :
6009 297 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6010 : }
6011 :
6012 31956 : if (clauses->thread_limit)
6013 : {
6014 109 : tree thread_limit;
6015 :
6016 109 : gfc_init_se (&se, NULL);
6017 109 : gfc_conv_expr (&se, clauses->thread_limit);
6018 109 : gfc_add_block_to_block (block, &se.pre);
6019 109 : thread_limit = gfc_evaluate_now (se.expr, block);
6020 109 : gfc_add_block_to_block (block, &se.post);
6021 :
6022 109 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT);
6023 109 : OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit;
6024 109 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6025 : }
6026 :
6027 31956 : chunk_size = NULL_TREE;
6028 31956 : if (clauses->dist_chunk_size)
6029 : {
6030 80 : gfc_init_se (&se, NULL);
6031 80 : gfc_conv_expr (&se, clauses->dist_chunk_size);
6032 80 : gfc_add_block_to_block (block, &se.pre);
6033 80 : chunk_size = gfc_evaluate_now (se.expr, block);
6034 80 : gfc_add_block_to_block (block, &se.post);
6035 : }
6036 :
6037 31956 : if (clauses->dist_sched_kind != OMP_SCHED_NONE)
6038 : {
6039 93 : c = build_omp_clause (gfc_get_location (&where),
6040 : OMP_CLAUSE_DIST_SCHEDULE);
6041 93 : OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
6042 93 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6043 : }
6044 :
6045 31956 : if (clauses->grainsize)
6046 : {
6047 33 : tree grainsize;
6048 :
6049 33 : gfc_init_se (&se, NULL);
6050 33 : gfc_conv_expr (&se, clauses->grainsize);
6051 33 : gfc_add_block_to_block (block, &se.pre);
6052 33 : grainsize = gfc_evaluate_now (se.expr, block);
6053 33 : gfc_add_block_to_block (block, &se.post);
6054 :
6055 33 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
6056 33 : OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
6057 33 : if (clauses->grainsize_strict)
6058 1 : OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
6059 33 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6060 : }
6061 :
6062 31956 : if (clauses->num_tasks)
6063 : {
6064 25 : tree num_tasks;
6065 :
6066 25 : gfc_init_se (&se, NULL);
6067 25 : gfc_conv_expr (&se, clauses->num_tasks);
6068 25 : gfc_add_block_to_block (block, &se.pre);
6069 25 : num_tasks = gfc_evaluate_now (se.expr, block);
6070 25 : gfc_add_block_to_block (block, &se.post);
6071 :
6072 25 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
6073 25 : OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
6074 25 : if (clauses->num_tasks_strict)
6075 1 : OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
6076 25 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6077 : }
6078 :
6079 31956 : if (clauses->priority)
6080 : {
6081 34 : tree priority;
6082 :
6083 34 : gfc_init_se (&se, NULL);
6084 34 : gfc_conv_expr (&se, clauses->priority);
6085 34 : gfc_add_block_to_block (block, &se.pre);
6086 34 : priority = gfc_evaluate_now (se.expr, block);
6087 34 : gfc_add_block_to_block (block, &se.post);
6088 :
6089 34 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY);
6090 34 : OMP_CLAUSE_PRIORITY_EXPR (c) = priority;
6091 34 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6092 : }
6093 :
6094 31956 : if (clauses->detach)
6095 : {
6096 116 : tree detach;
6097 :
6098 116 : gfc_init_se (&se, NULL);
6099 116 : gfc_conv_expr (&se, clauses->detach);
6100 116 : gfc_add_block_to_block (block, &se.pre);
6101 116 : detach = se.expr;
6102 116 : gfc_add_block_to_block (block, &se.post);
6103 :
6104 116 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
6105 116 : TREE_ADDRESSABLE (detach) = 1;
6106 116 : OMP_CLAUSE_DECL (c) = detach;
6107 116 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6108 : }
6109 :
6110 31956 : if (clauses->filter)
6111 : {
6112 31 : tree filter;
6113 :
6114 31 : gfc_init_se (&se, NULL);
6115 31 : gfc_conv_expr (&se, clauses->filter);
6116 31 : gfc_add_block_to_block (block, &se.pre);
6117 31 : filter = gfc_evaluate_now (se.expr, block);
6118 31 : gfc_add_block_to_block (block, &se.post);
6119 :
6120 31 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
6121 31 : OMP_CLAUSE_FILTER_EXPR (c) = filter;
6122 31 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6123 : }
6124 :
6125 31956 : if (clauses->hint)
6126 : {
6127 8 : tree hint;
6128 :
6129 8 : gfc_init_se (&se, NULL);
6130 8 : gfc_conv_expr (&se, clauses->hint);
6131 8 : gfc_add_block_to_block (block, &se.pre);
6132 8 : hint = gfc_evaluate_now (se.expr, block);
6133 8 : gfc_add_block_to_block (block, &se.post);
6134 :
6135 8 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT);
6136 8 : OMP_CLAUSE_HINT_EXPR (c) = hint;
6137 8 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6138 : }
6139 :
6140 31956 : if (clauses->simd)
6141 : {
6142 22 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD);
6143 22 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6144 : }
6145 31956 : if (clauses->threads)
6146 : {
6147 11 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS);
6148 11 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6149 : }
6150 31956 : if (clauses->nogroup)
6151 : {
6152 13 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
6153 13 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6154 : }
6155 :
6156 223692 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
6157 : {
6158 191736 : if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
6159 191584 : continue;
6160 152 : enum omp_clause_defaultmap_kind behavior, category;
6161 152 : switch ((gfc_omp_defaultmap_category) i)
6162 : {
6163 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
6164 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
6165 : break;
6166 : case OMP_DEFAULTMAP_CAT_ALL:
6167 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALL;
6168 : break;
6169 : case OMP_DEFAULTMAP_CAT_SCALAR:
6170 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
6171 : break;
6172 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
6173 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
6174 : break;
6175 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
6176 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
6177 : break;
6178 : case OMP_DEFAULTMAP_CAT_POINTER:
6179 : category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
6180 : break;
6181 : default: gcc_unreachable ();
6182 : }
6183 152 : switch (clauses->defaultmap[i])
6184 : {
6185 : case OMP_DEFAULTMAP_ALLOC:
6186 : behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
6187 : break;
6188 : case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
6189 : case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
6190 : case OMP_DEFAULTMAP_TOFROM:
6191 : behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
6192 : break;
6193 : case OMP_DEFAULTMAP_FIRSTPRIVATE:
6194 : behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
6195 : break;
6196 : case OMP_DEFAULTMAP_PRESENT:
6197 : behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT;
6198 : break;
6199 : case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
6200 : case OMP_DEFAULTMAP_DEFAULT:
6201 : behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
6202 : break;
6203 0 : default: gcc_unreachable ();
6204 : }
6205 152 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
6206 152 : OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
6207 152 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6208 : }
6209 :
6210 31956 : if (clauses->doacross_source)
6211 : {
6212 132 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
6213 132 : OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
6214 132 : OMP_CLAUSE_DOACROSS_DEPEND (c) = clauses->depend_source;
6215 132 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6216 : }
6217 :
6218 31956 : if (clauses->async)
6219 : {
6220 549 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC);
6221 549 : if (clauses->async_expr)
6222 549 : OMP_CLAUSE_ASYNC_EXPR (c)
6223 1098 : = gfc_convert_expr_to_tree (block, clauses->async_expr);
6224 : else
6225 0 : OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
6226 549 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6227 : }
6228 31956 : if (clauses->seq)
6229 : {
6230 140 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ);
6231 140 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6232 : }
6233 31956 : if (clauses->par_auto)
6234 : {
6235 62 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO);
6236 62 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6237 : }
6238 31956 : if (clauses->if_present)
6239 : {
6240 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT);
6241 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6242 : }
6243 31956 : if (clauses->finalize)
6244 : {
6245 23 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
6246 23 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6247 : }
6248 31956 : if (clauses->independent)
6249 : {
6250 239 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT);
6251 239 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6252 : }
6253 31956 : if (clauses->wait_list)
6254 : {
6255 : gfc_expr_list *el;
6256 :
6257 317 : for (el = clauses->wait_list; el; el = el->next)
6258 : {
6259 172 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT);
6260 172 : OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
6261 172 : OMP_CLAUSE_CHAIN (c) = omp_clauses;
6262 172 : omp_clauses = c;
6263 : }
6264 : }
6265 31956 : if (clauses->num_gangs_expr)
6266 : {
6267 666 : tree num_gangs_var
6268 666 : = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
6269 666 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS);
6270 666 : OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
6271 666 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6272 : }
6273 31956 : if (clauses->num_workers_expr)
6274 : {
6275 583 : tree num_workers_var
6276 583 : = gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
6277 583 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS);
6278 583 : OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var;
6279 583 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6280 : }
6281 31956 : if (clauses->vector_length_expr)
6282 : {
6283 553 : tree vector_length_var
6284 553 : = gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
6285 553 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH);
6286 553 : OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
6287 553 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6288 : }
6289 31956 : if (clauses->tile_list)
6290 : {
6291 : tree list = NULL_TREE;
6292 174 : for (gfc_expr_list *el = clauses->tile_list; el; el = el->next)
6293 114 : list = tree_cons (NULL_TREE, gfc_convert_expr_to_tree (block, el->expr),
6294 : list);
6295 :
6296 60 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE);
6297 60 : OMP_CLAUSE_TILE_LIST (c) = nreverse (list);
6298 60 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6299 : }
6300 31956 : if (clauses->vector)
6301 : {
6302 835 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
6303 835 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6304 :
6305 835 : if (clauses->vector_expr)
6306 : {
6307 119 : tree vector_var
6308 119 : = gfc_convert_expr_to_tree (block, clauses->vector_expr);
6309 119 : OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
6310 :
6311 : /* TODO: We're not capturing location information for individual
6312 : clauses. However, if we have an expression attached to the
6313 : clause, that one provides better location information. */
6314 238 : OMP_CLAUSE_LOCATION (c)
6315 119 : = gfc_get_location (&clauses->vector_expr->where);
6316 : }
6317 : }
6318 31956 : if (clauses->worker)
6319 : {
6320 730 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
6321 730 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6322 :
6323 730 : if (clauses->worker_expr)
6324 : {
6325 89 : tree worker_var
6326 89 : = gfc_convert_expr_to_tree (block, clauses->worker_expr);
6327 89 : OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
6328 :
6329 : /* TODO: We're not capturing location information for individual
6330 : clauses. However, if we have an expression attached to the
6331 : clause, that one provides better location information. */
6332 178 : OMP_CLAUSE_LOCATION (c)
6333 89 : = gfc_get_location (&clauses->worker_expr->where);
6334 : }
6335 : }
6336 31956 : if (clauses->gang)
6337 : {
6338 1011 : tree arg;
6339 1011 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG);
6340 1011 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6341 :
6342 1011 : if (clauses->gang_num_expr)
6343 : {
6344 101 : arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
6345 101 : OMP_CLAUSE_GANG_EXPR (c) = arg;
6346 :
6347 : /* TODO: We're not capturing location information for individual
6348 : clauses. However, if we have an expression attached to the
6349 : clause, that one provides better location information. */
6350 202 : OMP_CLAUSE_LOCATION (c)
6351 101 : = gfc_get_location (&clauses->gang_num_expr->where);
6352 : }
6353 :
6354 1011 : if (clauses->gang_static)
6355 : {
6356 15 : arg = clauses->gang_static_expr
6357 104 : ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
6358 : : integer_minus_one_node;
6359 104 : OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
6360 : }
6361 : }
6362 31956 : if (clauses->bind != OMP_BIND_UNSET)
6363 : {
6364 30 : c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
6365 30 : omp_clauses = gfc_trans_add_clause (c, omp_clauses);
6366 30 : switch (clauses->bind)
6367 : {
6368 10 : case OMP_BIND_TEAMS:
6369 10 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
6370 10 : break;
6371 15 : case OMP_BIND_PARALLEL:
6372 15 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
6373 15 : break;
6374 5 : case OMP_BIND_THREAD:
6375 5 : OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
6376 5 : break;
6377 0 : default:
6378 0 : gcc_unreachable ();
6379 : }
6380 : }
6381 : /* OpenACC 'nohost' clauses cannot appear here. */
6382 31956 : gcc_checking_assert (!clauses->nohost);
6383 :
6384 31956 : return nreverse (omp_clauses);
6385 : }
6386 :
6387 : /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
6388 :
6389 : static tree
6390 21188 : gfc_trans_omp_code (gfc_code *code, bool force_empty)
6391 : {
6392 21188 : tree stmt;
6393 :
6394 21188 : pushlevel ();
6395 21188 : stmt = gfc_trans_code (code);
6396 21188 : if (TREE_CODE (stmt) != BIND_EXPR)
6397 : {
6398 18817 : if (!IS_EMPTY_STMT (stmt) || force_empty)
6399 : {
6400 18727 : tree block = poplevel (1, 0);
6401 18727 : stmt = build3_v (BIND_EXPR, NULL, stmt, block);
6402 : }
6403 : else
6404 90 : poplevel (0, 0);
6405 : }
6406 : else
6407 2371 : poplevel (0, 0);
6408 21188 : return stmt;
6409 : }
6410 :
6411 : /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
6412 : construct. */
6413 :
6414 : static tree
6415 4189 : gfc_trans_oacc_construct (gfc_code *code)
6416 : {
6417 4189 : stmtblock_t block;
6418 4189 : tree stmt, oacc_clauses;
6419 4189 : enum tree_code construct_code;
6420 :
6421 4189 : switch (code->op)
6422 : {
6423 : case EXEC_OACC_PARALLEL:
6424 : construct_code = OACC_PARALLEL;
6425 : break;
6426 : case EXEC_OACC_KERNELS:
6427 : construct_code = OACC_KERNELS;
6428 : break;
6429 : case EXEC_OACC_SERIAL:
6430 : construct_code = OACC_SERIAL;
6431 : break;
6432 : case EXEC_OACC_DATA:
6433 : construct_code = OACC_DATA;
6434 : break;
6435 : case EXEC_OACC_HOST_DATA:
6436 : construct_code = OACC_HOST_DATA;
6437 : break;
6438 0 : default:
6439 0 : gcc_unreachable ();
6440 : }
6441 :
6442 4189 : gfc_start_block (&block);
6443 4189 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6444 : code->loc, false, true);
6445 4189 : pushlevel ();
6446 4189 : stmt = gfc_trans_omp_code (code->block->next, true);
6447 4189 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
6448 4189 : stmt = build2_loc (gfc_get_location (&code->loc), construct_code,
6449 : void_type_node, stmt, oacc_clauses);
6450 4189 : gfc_add_expr_to_block (&block, stmt);
6451 4189 : return gfc_finish_block (&block);
6452 : }
6453 :
6454 : /* update, enter_data, exit_data, cache. */
6455 : static tree
6456 2130 : gfc_trans_oacc_executable_directive (gfc_code *code)
6457 : {
6458 2130 : stmtblock_t block;
6459 2130 : tree stmt, oacc_clauses;
6460 2130 : enum tree_code construct_code;
6461 :
6462 2130 : switch (code->op)
6463 : {
6464 : case EXEC_OACC_UPDATE:
6465 : construct_code = OACC_UPDATE;
6466 : break;
6467 787 : case EXEC_OACC_ENTER_DATA:
6468 787 : construct_code = OACC_ENTER_DATA;
6469 787 : break;
6470 575 : case EXEC_OACC_EXIT_DATA:
6471 575 : construct_code = OACC_EXIT_DATA;
6472 575 : break;
6473 76 : case EXEC_OACC_CACHE:
6474 76 : construct_code = OACC_CACHE;
6475 76 : break;
6476 0 : default:
6477 0 : gcc_unreachable ();
6478 : }
6479 :
6480 2130 : gfc_start_block (&block);
6481 2130 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
6482 : code->loc, false, true, code->op);
6483 2130 : stmt = build1_loc (input_location, construct_code, void_type_node,
6484 : oacc_clauses);
6485 2130 : gfc_add_expr_to_block (&block, stmt);
6486 2130 : return gfc_finish_block (&block);
6487 : }
6488 :
6489 : static tree
6490 173 : gfc_trans_oacc_wait_directive (gfc_code *code)
6491 : {
6492 173 : stmtblock_t block;
6493 173 : tree stmt, t;
6494 173 : vec<tree, va_gc> *args;
6495 173 : int nparms = 0;
6496 173 : gfc_expr_list *el;
6497 173 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
6498 173 : location_t loc = input_location;
6499 :
6500 303 : for (el = clauses->wait_list; el; el = el->next)
6501 130 : nparms++;
6502 :
6503 173 : vec_alloc (args, nparms + 2);
6504 173 : stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
6505 :
6506 173 : gfc_start_block (&block);
6507 :
6508 173 : if (clauses->async_expr)
6509 3 : t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
6510 : else
6511 170 : t = build_int_cst (integer_type_node, -2);
6512 :
6513 173 : args->quick_push (t);
6514 173 : args->quick_push (build_int_cst (integer_type_node, nparms));
6515 :
6516 303 : for (el = clauses->wait_list; el; el = el->next)
6517 130 : args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
6518 :
6519 173 : stmt = build_call_expr_loc_vec (loc, stmt, args);
6520 173 : if (clauses->if_expr)
6521 6 : stmt = build3_loc (input_location, COND_EXPR, void_type_node,
6522 : gfc_convert_expr_to_tree (&block, clauses->if_expr),
6523 : stmt, NULL_TREE);
6524 173 : gfc_add_expr_to_block (&block, stmt);
6525 :
6526 173 : vec_free (args);
6527 :
6528 173 : return gfc_finish_block (&block);
6529 : }
6530 :
6531 : static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
6532 : static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
6533 :
6534 : static tree
6535 35 : gfc_trans_omp_allocators (gfc_code *code)
6536 : {
6537 35 : static bool warned = false;
6538 35 : gfc_omp_namelist *omp_allocate
6539 35 : = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6540 35 : if (!flag_openmp_allocators && !warned)
6541 : {
6542 3 : omp_allocate = NULL;
6543 3 : gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>",
6544 3 : code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS",
6545 : &code->loc);
6546 3 : warning (0, "All files that might deallocate such a variable must be "
6547 : "compiled with %<-fopenmp-allocators%>");
6548 3 : inform (UNKNOWN_LOCATION,
6549 : "This includes explicit DEALLOCATE, reallocation on intrinsic "
6550 : "assignment, INTENT(OUT) for allocatable dummy arguments, and "
6551 : "reallocation of allocatable components allocated with an "
6552 : "OpenMP allocator");
6553 3 : warned = true;
6554 : }
6555 35 : return gfc_trans_allocate (code->block->next, omp_allocate);
6556 : }
6557 :
6558 : static tree
6559 10 : gfc_trans_omp_assume (gfc_code *code)
6560 : {
6561 10 : stmtblock_t block;
6562 10 : gfc_init_block (&block);
6563 10 : gfc_omp_assumptions *assume = code->ext.omp_clauses->assume;
6564 10 : if (assume)
6565 19 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
6566 : {
6567 9 : location_t loc = gfc_get_location (&el->expr->where);
6568 9 : gfc_se se;
6569 9 : gfc_init_se (&se, NULL);
6570 9 : gfc_conv_expr (&se, el->expr);
6571 9 : tree t;
6572 9 : if (se.pre.head == NULL_TREE && se.post.head == NULL_TREE)
6573 8 : t = se.expr;
6574 : else
6575 : {
6576 1 : tree var = create_tmp_var_raw (boolean_type_node);
6577 1 : DECL_CONTEXT (var) = current_function_decl;
6578 1 : stmtblock_t block2;
6579 1 : gfc_init_block (&block2);
6580 1 : gfc_add_block_to_block (&block2, &se.pre);
6581 1 : gfc_add_modify_loc (loc, &block2, var,
6582 : fold_convert_loc (loc, boolean_type_node,
6583 : se.expr));
6584 1 : gfc_add_block_to_block (&block2, &se.post);
6585 1 : t = gfc_finish_block (&block2);
6586 1 : t = build4 (TARGET_EXPR, boolean_type_node, var, t, NULL, NULL);
6587 : }
6588 9 : t = build_call_expr_internal_loc (loc, IFN_ASSUME,
6589 : void_type_node, 1, t);
6590 9 : gfc_add_expr_to_block (&block, t);
6591 : }
6592 10 : gfc_add_expr_to_block (&block, gfc_trans_omp_code (code->block->next, true));
6593 10 : return gfc_finish_block (&block);
6594 : }
6595 :
6596 : static tree
6597 2552 : gfc_trans_omp_atomic (gfc_code *code)
6598 : {
6599 2552 : gfc_code *atomic_code = code->block;
6600 2552 : gfc_se lse;
6601 2552 : gfc_se rse;
6602 2552 : gfc_se vse;
6603 2552 : gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
6604 2552 : gfc_symbol *var;
6605 2552 : stmtblock_t block;
6606 2552 : tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
6607 2552 : enum tree_code op = ERROR_MARK;
6608 2552 : enum tree_code aop = OMP_ATOMIC;
6609 2552 : bool var_on_left = false, else_branch = false;
6610 2552 : enum omp_memory_order mo, fail_mo;
6611 2552 : switch (atomic_code->ext.omp_clauses->memorder)
6612 : {
6613 : case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
6614 : case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
6615 : case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
6616 : case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
6617 : case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
6618 : case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
6619 0 : default: gcc_unreachable ();
6620 : }
6621 2552 : switch (atomic_code->ext.omp_clauses->fail)
6622 : {
6623 : case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
6624 14 : case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
6625 26 : case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
6626 2 : case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
6627 0 : default: gcc_unreachable ();
6628 : }
6629 2552 : mo = (omp_memory_order) (mo | fail_mo);
6630 :
6631 2552 : code = code->block->next;
6632 2552 : if (atomic_code->ext.omp_clauses->compare)
6633 : {
6634 144 : gfc_expr *comp_expr;
6635 144 : if (code->op == EXEC_IF)
6636 : {
6637 125 : comp_expr = code->block->expr1;
6638 125 : gcc_assert (code->block->next->op == EXEC_ASSIGN);
6639 125 : expr1 = code->block->next->expr1;
6640 125 : expr2 = code->block->next->expr2;
6641 125 : if (code->block->block)
6642 : {
6643 64 : gcc_assert (atomic_code->ext.omp_clauses->capture
6644 : && code->block->block->next->op == EXEC_ASSIGN);
6645 64 : else_branch = true;
6646 64 : aop = OMP_ATOMIC_CAPTURE_OLD;
6647 64 : capture_expr1 = code->block->block->next->expr1;
6648 64 : capture_expr2 = code->block->block->next->expr2;
6649 : }
6650 61 : else if (atomic_code->ext.omp_clauses->capture)
6651 : {
6652 19 : gcc_assert (code->next->op == EXEC_ASSIGN);
6653 19 : aop = OMP_ATOMIC_CAPTURE_NEW;
6654 19 : capture_expr1 = code->next->expr1;
6655 19 : capture_expr2 = code->next->expr2;
6656 : }
6657 : }
6658 : else
6659 : {
6660 19 : gcc_assert (atomic_code->ext.omp_clauses->capture
6661 : && code->op == EXEC_ASSIGN
6662 : && code->next->op == EXEC_IF);
6663 19 : aop = OMP_ATOMIC_CAPTURE_OLD;
6664 19 : capture_expr1 = code->expr1;
6665 19 : capture_expr2 = code->expr2;
6666 19 : expr1 = code->next->block->next->expr1;
6667 19 : expr2 = code->next->block->next->expr2;
6668 19 : comp_expr = code->next->block->expr1;
6669 : }
6670 144 : gfc_init_se (&lse, NULL);
6671 144 : gfc_conv_expr (&lse, comp_expr->value.op.op2);
6672 144 : gfc_add_block_to_block (&block, &lse.pre);
6673 144 : compare = lse.expr;
6674 144 : var = expr1->symtree->n.sym;
6675 : }
6676 : else
6677 : {
6678 2408 : gcc_assert (code->op == EXEC_ASSIGN);
6679 2408 : expr1 = code->expr1;
6680 2408 : expr2 = code->expr2;
6681 2408 : if (atomic_code->ext.omp_clauses->capture
6682 463 : && (expr2->expr_type == EXPR_VARIABLE
6683 245 : || (expr2->expr_type == EXPR_FUNCTION
6684 113 : && expr2->value.function.isym
6685 113 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION
6686 41 : && (expr2->value.function.actual->expr->expr_type
6687 : == EXPR_VARIABLE))))
6688 : {
6689 235 : capture_expr1 = expr1;
6690 235 : capture_expr2 = expr2;
6691 235 : expr1 = code->next->expr1;
6692 235 : expr2 = code->next->expr2;
6693 235 : aop = OMP_ATOMIC_CAPTURE_OLD;
6694 : }
6695 2173 : else if (atomic_code->ext.omp_clauses->capture)
6696 : {
6697 228 : aop = OMP_ATOMIC_CAPTURE_NEW;
6698 228 : capture_expr1 = code->next->expr1;
6699 228 : capture_expr2 = code->next->expr2;
6700 : }
6701 2408 : var = expr1->symtree->n.sym;
6702 : }
6703 :
6704 2552 : gfc_init_se (&lse, NULL);
6705 2552 : gfc_init_se (&rse, NULL);
6706 2552 : gfc_init_se (&vse, NULL);
6707 2552 : gfc_start_block (&block);
6708 :
6709 2552 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6710 : != GFC_OMP_ATOMIC_WRITE)
6711 2146 : && expr2->expr_type == EXPR_FUNCTION
6712 472 : && expr2->value.function.isym
6713 472 : && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6714 139 : expr2 = expr2->value.function.actual->expr;
6715 :
6716 2552 : if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6717 : == GFC_OMP_ATOMIC_READ)
6718 : {
6719 494 : gfc_conv_expr (&vse, expr1);
6720 494 : gfc_add_block_to_block (&block, &vse.pre);
6721 :
6722 494 : gfc_conv_expr (&lse, expr2);
6723 494 : gfc_add_block_to_block (&block, &lse.pre);
6724 494 : type = TREE_TYPE (lse.expr);
6725 494 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6726 :
6727 494 : x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
6728 494 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6729 494 : x = convert (TREE_TYPE (vse.expr), x);
6730 494 : gfc_add_modify (&block, vse.expr, x);
6731 :
6732 494 : gfc_add_block_to_block (&block, &lse.pre);
6733 494 : gfc_add_block_to_block (&block, &rse.pre);
6734 :
6735 494 : return gfc_finish_block (&block);
6736 : }
6737 :
6738 2058 : if (capture_expr2
6739 565 : && capture_expr2->expr_type == EXPR_FUNCTION
6740 21 : && capture_expr2->value.function.isym
6741 21 : && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
6742 21 : capture_expr2 = capture_expr2->value.function.actual->expr;
6743 565 : gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
6744 :
6745 2058 : if (aop == OMP_ATOMIC_CAPTURE_OLD)
6746 : {
6747 318 : gfc_conv_expr (&vse, capture_expr1);
6748 318 : gfc_add_block_to_block (&block, &vse.pre);
6749 318 : gfc_conv_expr (&lse, capture_expr2);
6750 318 : gfc_add_block_to_block (&block, &lse.pre);
6751 318 : gfc_init_se (&lse, NULL);
6752 : }
6753 :
6754 2058 : gfc_conv_expr (&lse, expr1);
6755 2058 : gfc_add_block_to_block (&block, &lse.pre);
6756 2058 : type = TREE_TYPE (lse.expr);
6757 2058 : lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
6758 :
6759 2058 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6760 : == GFC_OMP_ATOMIC_WRITE)
6761 1652 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6762 1630 : || compare)
6763 : {
6764 572 : gfc_conv_expr (&rse, expr2);
6765 572 : gfc_add_block_to_block (&block, &rse.pre);
6766 : }
6767 1486 : else if (expr2->expr_type == EXPR_OP)
6768 : {
6769 1140 : gfc_expr *e;
6770 1140 : switch (expr2->value.op.op)
6771 : {
6772 : case INTRINSIC_PLUS:
6773 : op = PLUS_EXPR;
6774 : break;
6775 91 : case INTRINSIC_TIMES:
6776 91 : op = MULT_EXPR;
6777 91 : break;
6778 113 : case INTRINSIC_MINUS:
6779 113 : op = MINUS_EXPR;
6780 113 : break;
6781 91 : case INTRINSIC_DIVIDE:
6782 91 : if (expr2->ts.type == BT_INTEGER)
6783 : op = TRUNC_DIV_EXPR;
6784 : else
6785 74 : op = RDIV_EXPR;
6786 : break;
6787 43 : case INTRINSIC_AND:
6788 43 : op = TRUTH_ANDIF_EXPR;
6789 43 : break;
6790 49 : case INTRINSIC_OR:
6791 49 : op = TRUTH_ORIF_EXPR;
6792 49 : break;
6793 43 : case INTRINSIC_EQV:
6794 43 : op = EQ_EXPR;
6795 43 : break;
6796 43 : case INTRINSIC_NEQV:
6797 43 : op = NE_EXPR;
6798 43 : break;
6799 0 : default:
6800 0 : gcc_unreachable ();
6801 : }
6802 1140 : e = expr2->value.op.op1;
6803 1140 : if (e->expr_type == EXPR_FUNCTION
6804 48 : && e->value.function.isym
6805 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6806 48 : e = e->value.function.actual->expr;
6807 1140 : if (e->expr_type == EXPR_VARIABLE
6808 881 : && e->symtree != NULL
6809 881 : && e->symtree->n.sym == var)
6810 : {
6811 866 : expr2 = expr2->value.op.op2;
6812 866 : var_on_left = true;
6813 : }
6814 : else
6815 : {
6816 274 : e = expr2->value.op.op2;
6817 274 : if (e->expr_type == EXPR_FUNCTION
6818 48 : && e->value.function.isym
6819 48 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6820 48 : e = e->value.function.actual->expr;
6821 274 : gcc_assert (e->expr_type == EXPR_VARIABLE
6822 : && e->symtree != NULL
6823 : && e->symtree->n.sym == var);
6824 : expr2 = expr2->value.op.op1;
6825 : var_on_left = false;
6826 : }
6827 1140 : gfc_conv_expr (&rse, expr2);
6828 1140 : gfc_add_block_to_block (&block, &rse.pre);
6829 : }
6830 : else
6831 : {
6832 346 : gcc_assert (expr2->expr_type == EXPR_FUNCTION);
6833 346 : switch (expr2->value.function.isym->id)
6834 : {
6835 : case GFC_ISYM_MIN:
6836 : op = MIN_EXPR;
6837 : break;
6838 114 : case GFC_ISYM_MAX:
6839 114 : op = MAX_EXPR;
6840 114 : break;
6841 47 : case GFC_ISYM_IAND:
6842 47 : op = BIT_AND_EXPR;
6843 47 : break;
6844 49 : case GFC_ISYM_IOR:
6845 49 : op = BIT_IOR_EXPR;
6846 49 : break;
6847 45 : case GFC_ISYM_IEOR:
6848 45 : op = BIT_XOR_EXPR;
6849 45 : break;
6850 0 : default:
6851 0 : gcc_unreachable ();
6852 : }
6853 346 : e = expr2->value.function.actual->expr;
6854 346 : if (e->expr_type == EXPR_FUNCTION
6855 13 : && e->value.function.isym
6856 13 : && e->value.function.isym->id == GFC_ISYM_CONVERSION)
6857 13 : e = e->value.function.actual->expr;
6858 346 : gcc_assert (e->expr_type == EXPR_VARIABLE
6859 : && e->symtree != NULL
6860 : && e->symtree->n.sym == var);
6861 :
6862 346 : gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
6863 346 : gfc_add_block_to_block (&block, &rse.pre);
6864 346 : if (expr2->value.function.actual->next->next != NULL)
6865 : {
6866 26 : tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
6867 26 : gfc_actual_arglist *arg;
6868 :
6869 26 : gfc_add_modify (&block, accum, rse.expr);
6870 64 : for (arg = expr2->value.function.actual->next->next; arg;
6871 38 : arg = arg->next)
6872 : {
6873 38 : gfc_init_block (&rse.pre);
6874 38 : gfc_conv_expr (&rse, arg->expr);
6875 38 : gfc_add_block_to_block (&block, &rse.pre);
6876 38 : x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
6877 : accum, rse.expr);
6878 38 : gfc_add_modify (&block, accum, x);
6879 : }
6880 :
6881 26 : rse.expr = accum;
6882 : }
6883 :
6884 346 : expr2 = expr2->value.function.actual->next->expr;
6885 : }
6886 :
6887 2058 : lhsaddr = save_expr (lhsaddr);
6888 2058 : if (TREE_CODE (lhsaddr) != SAVE_EXPR
6889 2058 : && (TREE_CODE (lhsaddr) != ADDR_EXPR
6890 1600 : || !VAR_P (TREE_OPERAND (lhsaddr, 0))))
6891 : {
6892 : /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
6893 : it even after unsharing function body. */
6894 43 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6895 43 : DECL_CONTEXT (var) = current_function_decl;
6896 43 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
6897 : NULL_TREE, NULL_TREE);
6898 : }
6899 :
6900 2058 : if (compare)
6901 : {
6902 144 : tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
6903 144 : DECL_CONTEXT (var) = current_function_decl;
6904 144 : lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
6905 : NULL);
6906 144 : lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
6907 144 : compare = convert (TREE_TYPE (lse.expr), compare);
6908 144 : compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6909 : lse.expr, compare);
6910 : }
6911 :
6912 2058 : if (expr2->expr_type == EXPR_VARIABLE || compare)
6913 459 : rhs = rse.expr;
6914 : else
6915 1599 : rhs = gfc_evaluate_now (rse.expr, &block);
6916 :
6917 2058 : if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
6918 : == GFC_OMP_ATOMIC_WRITE)
6919 1652 : || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
6920 1630 : || compare)
6921 : x = rhs;
6922 : else
6923 : {
6924 1486 : x = convert (TREE_TYPE (rhs),
6925 : build_fold_indirect_ref_loc (input_location, lhsaddr));
6926 1486 : if (var_on_left)
6927 866 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
6928 : else
6929 620 : x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
6930 : }
6931 :
6932 2058 : if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
6933 2058 : && TREE_CODE (type) != COMPLEX_TYPE)
6934 0 : x = fold_build1_loc (input_location, REALPART_EXPR,
6935 0 : TREE_TYPE (TREE_TYPE (rhs)), x);
6936 :
6937 2058 : gfc_add_block_to_block (&block, &lse.pre);
6938 2058 : gfc_add_block_to_block (&block, &rse.pre);
6939 :
6940 2058 : if (aop == OMP_ATOMIC_CAPTURE_NEW)
6941 : {
6942 247 : gfc_conv_expr (&vse, capture_expr1);
6943 247 : gfc_add_block_to_block (&block, &vse.pre);
6944 247 : gfc_add_block_to_block (&block, &lse.pre);
6945 : }
6946 :
6947 2058 : if (compare && else_branch)
6948 : {
6949 64 : tree var2 = create_tmp_var_raw (boolean_type_node);
6950 64 : DECL_CONTEXT (var2) = current_function_decl;
6951 64 : comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
6952 : boolean_false_node, NULL, NULL);
6953 64 : compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
6954 : var2, compare);
6955 64 : TREE_OPERAND (compare, 0) = comp_tgt;
6956 64 : compare = omit_one_operand_loc (input_location, boolean_type_node,
6957 : compare, comp_tgt);
6958 : }
6959 :
6960 2058 : if (compare)
6961 144 : x = build3_loc (input_location, COND_EXPR, type, compare,
6962 : convert (type, x), lse.expr);
6963 :
6964 2058 : if (aop == OMP_ATOMIC)
6965 : {
6966 1493 : x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
6967 1493 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6968 1493 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6969 1493 : gfc_add_expr_to_block (&block, x);
6970 : }
6971 : else
6972 : {
6973 565 : x = build2 (aop, type, lhsaddr, convert (type, x));
6974 565 : OMP_ATOMIC_MEMORY_ORDER (x) = mo;
6975 565 : OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
6976 565 : if (compare && else_branch)
6977 : {
6978 64 : tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
6979 64 : DECL_CONTEXT (vtmp) = current_function_decl;
6980 64 : x = fold_build2_loc (input_location, MODIFY_EXPR,
6981 64 : TREE_TYPE (vtmp), vtmp, x);
6982 64 : vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
6983 64 : build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
6984 64 : TREE_OPERAND (x, 0) = vtmp;
6985 64 : tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
6986 64 : x2 = fold_build2_loc (input_location, MODIFY_EXPR,
6987 64 : TREE_TYPE (vse.expr), vse.expr, x2);
6988 64 : x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
6989 : void_node, x2);
6990 64 : x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
6991 64 : gfc_add_expr_to_block (&block, x);
6992 : }
6993 : else
6994 : {
6995 501 : x = convert (TREE_TYPE (vse.expr), x);
6996 501 : gfc_add_modify (&block, vse.expr, x);
6997 : }
6998 : }
6999 :
7000 2058 : return gfc_finish_block (&block);
7001 : }
7002 :
7003 : static tree
7004 580 : gfc_trans_omp_barrier (void)
7005 : {
7006 580 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
7007 580 : return build_call_expr_loc (input_location, decl, 1,
7008 : build_int_cst (integer_type_node,
7009 580 : GOMP_BARRIER_EXPLICIT));
7010 : }
7011 :
7012 : static tree
7013 232 : gfc_trans_omp_cancel (gfc_code *code)
7014 : {
7015 232 : int mask = 0;
7016 232 : tree ifc = boolean_true_node;
7017 232 : stmtblock_t block;
7018 232 : switch (code->ext.omp_clauses->cancel)
7019 : {
7020 : case OMP_CANCEL_PARALLEL: mask = 1; break;
7021 : case OMP_CANCEL_DO: mask = 2; break;
7022 : case OMP_CANCEL_SECTIONS: mask = 4; break;
7023 : case OMP_CANCEL_TASKGROUP: mask = 8; break;
7024 0 : default: gcc_unreachable ();
7025 : }
7026 232 : gfc_start_block (&block);
7027 232 : if (code->ext.omp_clauses->if_expr
7028 219 : || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
7029 : {
7030 21 : gfc_se se;
7031 21 : tree if_var;
7032 :
7033 21 : gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
7034 : ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
7035 21 : gfc_init_se (&se, NULL);
7036 21 : gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL
7037 : ? code->ext.omp_clauses->if_expr
7038 : : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
7039 21 : gfc_add_block_to_block (&block, &se.pre);
7040 21 : if_var = gfc_evaluate_now (se.expr, &block);
7041 21 : gfc_add_block_to_block (&block, &se.post);
7042 21 : tree type = TREE_TYPE (if_var);
7043 21 : ifc = fold_build2_loc (input_location, NE_EXPR,
7044 : boolean_type_node, if_var,
7045 : build_zero_cst (type));
7046 : }
7047 232 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
7048 232 : tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
7049 232 : ifc = fold_convert (c_bool_type, ifc);
7050 232 : gfc_add_expr_to_block (&block,
7051 : build_call_expr_loc (input_location, decl, 2,
7052 : build_int_cst (integer_type_node,
7053 232 : mask), ifc));
7054 232 : return gfc_finish_block (&block);
7055 : }
7056 :
7057 : static tree
7058 170 : gfc_trans_omp_cancellation_point (gfc_code *code)
7059 : {
7060 170 : int mask = 0;
7061 170 : switch (code->ext.omp_clauses->cancel)
7062 : {
7063 : case OMP_CANCEL_PARALLEL: mask = 1; break;
7064 : case OMP_CANCEL_DO: mask = 2; break;
7065 : case OMP_CANCEL_SECTIONS: mask = 4; break;
7066 : case OMP_CANCEL_TASKGROUP: mask = 8; break;
7067 0 : default: gcc_unreachable ();
7068 : }
7069 170 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
7070 170 : return build_call_expr_loc (input_location, decl, 1,
7071 340 : build_int_cst (integer_type_node, mask));
7072 : }
7073 :
7074 : static tree
7075 143 : gfc_trans_omp_critical (gfc_code *code)
7076 : {
7077 143 : stmtblock_t block;
7078 143 : tree stmt, name = NULL_TREE;
7079 143 : if (code->ext.omp_clauses->critical_name != NULL)
7080 36 : name = get_identifier (code->ext.omp_clauses->critical_name);
7081 143 : gfc_start_block (&block);
7082 143 : stmt = make_node (OMP_CRITICAL);
7083 143 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7084 143 : TREE_TYPE (stmt) = void_type_node;
7085 143 : OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
7086 143 : OMP_CRITICAL_NAME (stmt) = name;
7087 143 : OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
7088 : code->ext.omp_clauses,
7089 : code->loc);
7090 143 : gfc_add_expr_to_block (&block, stmt);
7091 143 : return gfc_finish_block (&block);
7092 : }
7093 :
7094 : typedef struct dovar_init_d {
7095 : gfc_symbol *sym;
7096 : tree var;
7097 : tree init;
7098 : bool non_unit_iter;
7099 : } dovar_init;
7100 :
7101 : static bool
7102 2884 : gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
7103 : gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
7104 : int simple, gfc_expr *curr_loop_var)
7105 : {
7106 2884 : int i;
7107 4771 : for (i = 0; i < loop_n; i++)
7108 : {
7109 2441 : gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
7110 2441 : if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
7111 : break;
7112 1887 : code = code->block->next;
7113 : }
7114 2884 : if (i >= loop_n)
7115 : return false;
7116 :
7117 : /* Canonical format: TREE_VEC with [var, multiplier, offset]. */
7118 554 : gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
7119 :
7120 554 : tree tree_var = NULL_TREE;
7121 554 : tree a1 = integer_one_node;
7122 554 : tree a2 = integer_zero_node;
7123 :
7124 554 : if (!simple)
7125 : {
7126 : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
7127 6 : sorry_at (gfc_get_location (&curr_loop_var->where),
7128 : "non-rectangular loop nest with non-constant step for %qs",
7129 3 : curr_loop_var->symtree->n.sym->name);
7130 3 : return false;
7131 : }
7132 :
7133 : dovar_init *di;
7134 : unsigned ix;
7135 551 : FOR_EACH_VEC_ELT (*inits, ix, di)
7136 18 : if (di->sym == var)
7137 : {
7138 18 : if (!di->non_unit_iter)
7139 : {
7140 16 : tree_var = di->init;
7141 16 : gcc_assert (DECL_P (tree_var));
7142 : break;
7143 : }
7144 : else
7145 : {
7146 : /* FIXME: Handle non-const iter steps, cf. PR fortran/110735. */
7147 2 : sorry_at (gfc_get_location (&code->loc),
7148 : "non-rectangular loop nest with non-constant step "
7149 : "for %qs", var->name);
7150 2 : inform (gfc_get_location (&expr->where), "Used here");
7151 2 : return false;
7152 : }
7153 : }
7154 533 : if (tree_var == NULL_TREE)
7155 533 : tree_var = var->backend_decl;
7156 :
7157 549 : if (expr->expr_type == EXPR_VARIABLE)
7158 54 : gcc_assert (expr->symtree->n.sym == var);
7159 495 : else if (expr->expr_type != EXPR_OP
7160 495 : || (expr->value.op.op != INTRINSIC_TIMES
7161 479 : && expr->value.op.op != INTRINSIC_PLUS
7162 359 : && expr->value.op.op != INTRINSIC_MINUS))
7163 0 : gcc_unreachable ();
7164 : else
7165 : {
7166 495 : gfc_se se;
7167 495 : gfc_expr *et = NULL, *eo = NULL, *e = expr;
7168 495 : if (expr->value.op.op != INTRINSIC_TIMES)
7169 : {
7170 479 : if (gfc_find_sym_in_expr (var, expr->value.op.op1))
7171 : {
7172 431 : e = expr->value.op.op1;
7173 431 : eo = expr->value.op.op2;
7174 : }
7175 : else
7176 : {
7177 48 : eo = expr->value.op.op1;
7178 48 : e = expr->value.op.op2;
7179 : }
7180 : }
7181 495 : if (e->value.op.op == INTRINSIC_TIMES)
7182 : {
7183 91 : if (e->value.op.op1->expr_type == EXPR_VARIABLE
7184 91 : && e->value.op.op1->symtree->n.sym == var)
7185 51 : et = e->value.op.op2;
7186 : else
7187 : {
7188 40 : et = e->value.op.op1;
7189 40 : gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
7190 : && e->value.op.op2->symtree->n.sym == var);
7191 : }
7192 : }
7193 : else
7194 404 : gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
7195 91 : if (et != NULL)
7196 : {
7197 91 : gfc_init_se (&se, NULL);
7198 91 : gfc_conv_expr_val (&se, et);
7199 91 : gfc_add_block_to_block (pblock, &se.pre);
7200 91 : a1 = se.expr;
7201 : }
7202 495 : if (eo != NULL)
7203 : {
7204 479 : gfc_init_se (&se, NULL);
7205 479 : gfc_conv_expr_val (&se, eo);
7206 479 : gfc_add_block_to_block (pblock, &se.pre);
7207 479 : a2 = se.expr;
7208 479 : if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
7209 : /* outer-var - a2. */
7210 335 : a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
7211 144 : else if (expr->value.op.op == INTRINSIC_MINUS)
7212 : /* a2 - outer-var. */
7213 24 : a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
7214 : }
7215 495 : a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
7216 495 : a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
7217 : }
7218 :
7219 549 : gfc_init_se (sep, NULL);
7220 549 : sep->expr = make_tree_vec (3);
7221 549 : TREE_VEC_ELT (sep->expr, 0) = tree_var;
7222 549 : TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
7223 549 : TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
7224 :
7225 549 : return true;
7226 : }
7227 :
7228 : int
7229 708 : gfc_expr_list_len (gfc_expr_list *list)
7230 : {
7231 708 : unsigned len = 0;
7232 2092 : for (; list; list = list->next)
7233 1384 : len++;
7234 :
7235 708 : return len;
7236 : }
7237 :
7238 : static tree
7239 9444 : gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
7240 : gfc_omp_clauses *do_clauses, tree par_clauses)
7241 : {
7242 9444 : gfc_se se;
7243 9444 : tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
7244 9444 : tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
7245 9444 : stmtblock_t block;
7246 9444 : stmtblock_t body;
7247 9444 : gfc_omp_clauses *clauses = code->ext.omp_clauses;
7248 9444 : int i, collapse = clauses->collapse;
7249 9444 : vec<dovar_init> inits = vNULL;
7250 9444 : dovar_init *di;
7251 9444 : unsigned ix;
7252 9444 : vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
7253 18888 : gfc_expr_list *oacc_tile
7254 9444 : = do_clauses ? do_clauses->tile_list : clauses->tile_list;
7255 9444 : gfc_expr_list *sizes
7256 : = do_clauses ? do_clauses->sizes_list : clauses->sizes_list;
7257 9444 : gfc_code *orig_code = code;
7258 :
7259 : /* Both collapsed and tiled loops are lowered the same way. In
7260 : OpenACC, those clauses are not compatible, so prioritize the tile
7261 : clause, if present. */
7262 9444 : if (oacc_tile)
7263 60 : collapse = gfc_expr_list_len (oacc_tile);
7264 9384 : else if (sizes)
7265 120 : collapse = gfc_expr_list_len (sizes);
7266 :
7267 9444 : doacross_steps = NULL;
7268 9444 : if (clauses->orderedc)
7269 134 : collapse = clauses->orderedc;
7270 9444 : if (collapse <= 0)
7271 : collapse = 1;
7272 :
7273 9444 : code = code->block->next;
7274 :
7275 9444 : init = make_tree_vec (collapse);
7276 9444 : cond = make_tree_vec (collapse);
7277 9444 : incr = make_tree_vec (collapse);
7278 9444 : orig_decls = clauses->ordered ? make_tree_vec (collapse) : NULL_TREE;
7279 :
7280 9444 : if (pblock == NULL)
7281 : {
7282 5949 : gfc_start_block (&block);
7283 5949 : pblock = █
7284 : }
7285 :
7286 : /* simd schedule modifier is only useful for composite do simd and other
7287 : constructs including that, where gfc_trans_omp_do is only called
7288 : on the simd construct and DO's clauses are translated elsewhere. */
7289 9444 : do_clauses->sched_simd = false;
7290 :
7291 9444 : omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
7292 :
7293 21362 : for (i = 0; i < collapse; i++)
7294 : {
7295 11918 : int simple = 0;
7296 11918 : int dovar_found = 0;
7297 11918 : tree dovar_decl;
7298 :
7299 11918 : if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
7300 : {
7301 320 : TREE_VEC_ELT (init, i) = NULL_TREE;
7302 320 : TREE_VEC_ELT (cond, i) = NULL_TREE;
7303 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
7304 320 : TREE_VEC_ELT (incr, i) = NULL_TREE;
7305 320 : if (orig_decls)
7306 2 : TREE_VEC_ELT (orig_decls, i) = NULL_TREE;
7307 320 : continue;
7308 : }
7309 11598 : gcc_assert (code->op == EXEC_DO);
7310 11598 : if (clauses)
7311 : {
7312 11598 : gfc_omp_namelist *n = NULL;
7313 11598 : if (op == EXEC_OMP_SIMD && collapse == 1)
7314 936 : for (n = clauses->lists[OMP_LIST_LINEAR];
7315 1236 : n != NULL; n = n->next)
7316 443 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7317 : {
7318 : dovar_found = 3;
7319 : break;
7320 : }
7321 11598 : if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
7322 11364 : for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
7323 13353 : n != NULL; n = n->next)
7324 3324 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7325 : {
7326 : dovar_found = 2;
7327 : break;
7328 : }
7329 11598 : if (n == NULL)
7330 11370 : for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
7331 6986 : if (code->ext.iterator->var->symtree->n.sym == n->sym)
7332 : {
7333 : dovar_found = 1;
7334 : break;
7335 : }
7336 : }
7337 :
7338 : /* Evaluate all the expressions in the iterator. */
7339 11598 : gfc_init_se (&se, NULL);
7340 11598 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
7341 11598 : gfc_add_block_to_block (pblock, &se.pre);
7342 11598 : local_dovar = dovar_decl = dovar = se.expr;
7343 11598 : type = TREE_TYPE (dovar);
7344 11598 : gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
7345 :
7346 11598 : gfc_init_se (&se, NULL);
7347 11598 : gfc_conv_expr_val (&se, code->ext.iterator->step);
7348 11598 : gfc_add_block_to_block (pblock, &se.pre);
7349 11598 : step = gfc_evaluate_now (se.expr, pblock);
7350 :
7351 11598 : if (TREE_CODE (step) == INTEGER_CST)
7352 11007 : simple = tree_int_cst_sgn (step);
7353 :
7354 11598 : gfc_init_se (&se, NULL);
7355 11598 : if (!clauses->non_rectangular
7356 13040 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
7357 : code->ext.iterator->start, &inits, simple,
7358 1442 : code->ext.iterator->var))
7359 : {
7360 11282 : gfc_conv_expr_val (&se, code->ext.iterator->start);
7361 11282 : gfc_add_block_to_block (pblock, &se.pre);
7362 11282 : if (!DECL_P (se.expr))
7363 10884 : se.expr = gfc_evaluate_now (se.expr, pblock);
7364 : }
7365 11598 : from = se.expr;
7366 :
7367 11598 : gfc_init_se (&se, NULL);
7368 11598 : if (!clauses->non_rectangular
7369 13040 : || !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
7370 : code->ext.iterator->end, &inits, simple,
7371 1442 : code->ext.iterator->var))
7372 : {
7373 11365 : gfc_conv_expr_val (&se, code->ext.iterator->end);
7374 11365 : gfc_add_block_to_block (pblock, &se.pre);
7375 11365 : if (!DECL_P (se.expr))
7376 10130 : se.expr = gfc_evaluate_now (se.expr, pblock);
7377 : }
7378 11598 : to = se.expr;
7379 :
7380 11598 : if (!DECL_P (dovar))
7381 38 : dovar_decl
7382 38 : = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
7383 : false);
7384 11598 : if (simple && !DECL_P (dovar))
7385 : {
7386 38 : const char *name = code->ext.iterator->var->symtree->n.sym->name;
7387 38 : local_dovar = gfc_create_var (type, name);
7388 38 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
7389 38 : dovar, local_dovar, false};
7390 38 : inits.safe_push (e);
7391 : }
7392 : /* Loop body. */
7393 11598 : if (simple)
7394 : {
7395 11007 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
7396 : /* The condition should not be folded. */
7397 11559 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
7398 : ? LE_EXPR : GE_EXPR,
7399 : logical_type_node, local_dovar,
7400 : to);
7401 11007 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
7402 : type, local_dovar, step);
7403 11007 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
7404 : MODIFY_EXPR,
7405 : type, local_dovar,
7406 11007 : TREE_VEC_ELT (incr, i));
7407 11007 : if (orig_decls && !clauses->orderedc)
7408 : orig_decls = NULL;
7409 383 : else if (orig_decls)
7410 383 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
7411 : }
7412 : else
7413 : {
7414 : /* STEP is not 1 or -1. Use:
7415 : for (count = 0; count < (to + step - from) / step; count++)
7416 : {
7417 : dovar = from + count * step;
7418 : body;
7419 : cycle_label:;
7420 : } */
7421 591 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
7422 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
7423 591 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
7424 : step);
7425 591 : tmp = gfc_evaluate_now (tmp, pblock);
7426 591 : local_dovar = gfc_create_var (type, "count");
7427 591 : TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
7428 : build_int_cst (type, 0));
7429 : /* The condition should not be folded. */
7430 591 : TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
7431 : logical_type_node,
7432 : local_dovar, tmp);
7433 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
7434 : type, local_dovar,
7435 : build_int_cst (type, 1));
7436 591 : TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
7437 : MODIFY_EXPR, type,
7438 : local_dovar,
7439 591 : TREE_VEC_ELT (incr, i));
7440 :
7441 : /* Initialize DOVAR. */
7442 591 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
7443 : step);
7444 591 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
7445 591 : dovar_init e = {code->ext.iterator->var->symtree->n.sym,
7446 591 : dovar, tmp, true};
7447 591 : inits.safe_push (e);
7448 591 : if (clauses->orderedc)
7449 : {
7450 192 : if (doacross_steps == NULL)
7451 47 : vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true);
7452 192 : (*doacross_steps)[i] = step;
7453 : }
7454 591 : if (orig_decls)
7455 198 : TREE_VEC_ELT (orig_decls, i) = dovar_decl;
7456 : }
7457 :
7458 11598 : if (dovar_found == 3
7459 11598 : && op == EXEC_OMP_SIMD
7460 143 : && collapse == 1
7461 143 : && local_dovar != dovar)
7462 : {
7463 120 : for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
7464 120 : if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
7465 120 : && OMP_CLAUSE_DECL (tmp) == dovar)
7466 : {
7467 30 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7468 30 : break;
7469 : }
7470 : }
7471 11598 : if (!dovar_found && op == EXEC_OMP_SIMD)
7472 : {
7473 1356 : if (collapse == 1)
7474 : {
7475 783 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7476 783 : OMP_CLAUSE_LINEAR_STEP (tmp) = step;
7477 783 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7478 783 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7479 783 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7480 783 : if (local_dovar != dovar)
7481 : dovar_found = 3;
7482 : }
7483 : }
7484 10242 : else if (!dovar_found && local_dovar != dovar)
7485 : {
7486 260 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7487 260 : OMP_CLAUSE_DECL (tmp) = dovar_decl;
7488 260 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7489 : }
7490 11568 : if (dovar_found > 1)
7491 : {
7492 1508 : tree c = NULL;
7493 :
7494 1508 : tmp = NULL;
7495 1508 : if (local_dovar != dovar)
7496 : {
7497 : /* If dovar is lastprivate, but different counter is used,
7498 : dovar += step needs to be added to
7499 : OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
7500 : will have the value on entry of the last loop, rather
7501 : than value after iterator increment. */
7502 243 : if (clauses->orderedc)
7503 : {
7504 60 : if (clauses->collapse <= 1 || i >= clauses->collapse)
7505 : tmp = local_dovar;
7506 : else
7507 36 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
7508 : type, local_dovar,
7509 : build_one_cst (type));
7510 60 : tmp = fold_build2_loc (input_location, MULT_EXPR, type,
7511 : tmp, step);
7512 60 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7513 : from, tmp);
7514 : }
7515 : else
7516 183 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
7517 : dovar, step);
7518 243 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
7519 : dovar, tmp);
7520 934 : for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7521 613 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7522 613 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7523 : {
7524 105 : OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
7525 105 : break;
7526 : }
7527 508 : else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
7528 508 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7529 : {
7530 60 : OMP_CLAUSE_LINEAR_STMT (c) = tmp;
7531 60 : break;
7532 : }
7533 : }
7534 1508 : if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
7535 : {
7536 892 : for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
7537 892 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
7538 892 : && OMP_CLAUSE_DECL (c) == dovar_decl)
7539 : {
7540 406 : tree l = build_omp_clause (input_location,
7541 : OMP_CLAUSE_LASTPRIVATE);
7542 406 : if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
7543 4 : OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
7544 406 : OMP_CLAUSE_DECL (l) = dovar_decl;
7545 406 : OMP_CLAUSE_CHAIN (l) = omp_clauses;
7546 406 : OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
7547 406 : omp_clauses = l;
7548 406 : OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
7549 406 : break;
7550 : }
7551 : }
7552 1508 : gcc_assert (local_dovar == dovar || c != NULL);
7553 : }
7554 11598 : if (local_dovar != dovar)
7555 : {
7556 629 : if (op != EXEC_OMP_SIMD || dovar_found == 1)
7557 550 : tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
7558 79 : else if (collapse == 1)
7559 : {
7560 60 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
7561 60 : OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1);
7562 60 : OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
7563 60 : OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
7564 : }
7565 : else
7566 19 : tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
7567 629 : OMP_CLAUSE_DECL (tmp) = local_dovar;
7568 629 : omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
7569 : }
7570 :
7571 11598 : if (i + 1 < collapse)
7572 2446 : code = code->block->next;
7573 : }
7574 :
7575 9444 : if (pblock != &block)
7576 : {
7577 3495 : pushlevel ();
7578 3495 : gfc_start_block (&block);
7579 : }
7580 :
7581 9444 : gfc_start_block (&body);
7582 :
7583 19517 : FOR_EACH_VEC_ELT (inits, ix, di)
7584 629 : gfc_add_modify (&body, di->var, di->init);
7585 9444 : inits.release ();
7586 :
7587 : /* Cycle statement is implemented with a goto. Exit statement must not be
7588 : present for this loop. */
7589 9444 : cycle_label = gfc_build_label_decl (NULL_TREE);
7590 :
7591 : /* Put these labels where they can be found later. */
7592 :
7593 9444 : code->cycle_label = cycle_label;
7594 9444 : code->exit_label = NULL_TREE;
7595 :
7596 : /* Main loop body. */
7597 9444 : if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7598 : {
7599 16 : gfc_code *code1, *scan, *code2, *tmpcode;
7600 16 : code1 = tmpcode = code->block->next;
7601 16 : if (tmpcode && tmpcode->op != EXEC_OMP_SCAN)
7602 18 : while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN)
7603 : tmpcode = tmpcode->next;
7604 16 : scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next;
7605 16 : if (code1 != scan)
7606 16 : tmpcode->next = NULL;
7607 16 : code2 = scan->next;
7608 16 : gcc_assert (scan->op == EXEC_OMP_SCAN);
7609 16 : location_t loc = gfc_get_location (&scan->loc);
7610 :
7611 16 : tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc);
7612 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
7613 16 : SET_EXPR_LOCATION (tmp, loc);
7614 16 : gfc_add_expr_to_block (&body, tmp);
7615 16 : input_location = loc;
7616 16 : tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc);
7617 16 : tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc);
7618 16 : tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
7619 16 : SET_EXPR_LOCATION (tmp, loc);
7620 16 : if (code1 != scan)
7621 16 : tmpcode->next = scan;
7622 : }
7623 9428 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
7624 292 : tmp = gfc_trans_omp_code (code, true);
7625 : else
7626 9136 : tmp = gfc_trans_omp_code (code->block->next, true);
7627 9444 : gfc_add_expr_to_block (&body, tmp);
7628 :
7629 : /* Label for cycle statements (if needed). */
7630 9444 : if (TREE_USED (cycle_label))
7631 : {
7632 9444 : tmp = build1_v (LABEL_EXPR, cycle_label);
7633 9444 : gfc_add_expr_to_block (&body, tmp);
7634 : }
7635 :
7636 : /* End of loop body. */
7637 9444 : switch (op)
7638 : {
7639 1455 : case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
7640 2330 : case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
7641 77 : case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
7642 113 : case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
7643 94 : case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
7644 4933 : case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
7645 120 : case EXEC_OMP_TILE: stmt = make_node (OMP_TILE); break;
7646 322 : case EXEC_OMP_UNROLL: stmt = make_node (OMP_UNROLL); break;
7647 0 : default: gcc_unreachable ();
7648 : }
7649 :
7650 9444 : SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc));
7651 9444 : TREE_TYPE (stmt) = void_type_node;
7652 9444 : OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
7653 9444 : OMP_FOR_CLAUSES (stmt) = omp_clauses;
7654 9444 : OMP_FOR_INIT (stmt) = init;
7655 9444 : OMP_FOR_COND (stmt) = cond;
7656 9444 : OMP_FOR_INCR (stmt) = incr;
7657 9444 : if (orig_decls)
7658 140 : OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
7659 9444 : OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
7660 9444 : gfc_add_expr_to_block (&block, stmt);
7661 :
7662 9444 : vec_free (doacross_steps);
7663 9444 : doacross_steps = saved_doacross_steps;
7664 :
7665 9444 : return gfc_finish_block (&block);
7666 : }
7667 :
7668 : /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
7669 : construct. */
7670 :
7671 : static tree
7672 1556 : gfc_trans_oacc_combined_directive (gfc_code *code)
7673 : {
7674 1556 : stmtblock_t block, *pblock = NULL;
7675 1556 : gfc_omp_clauses construct_clauses, loop_clauses;
7676 1556 : tree stmt, oacc_clauses = NULL_TREE;
7677 1556 : enum tree_code construct_code;
7678 1556 : location_t loc = input_location;
7679 :
7680 1556 : switch (code->op)
7681 : {
7682 : case EXEC_OACC_PARALLEL_LOOP:
7683 : construct_code = OACC_PARALLEL;
7684 : break;
7685 : case EXEC_OACC_KERNELS_LOOP:
7686 : construct_code = OACC_KERNELS;
7687 : break;
7688 : case EXEC_OACC_SERIAL_LOOP:
7689 : construct_code = OACC_SERIAL;
7690 : break;
7691 0 : default:
7692 0 : gcc_unreachable ();
7693 : }
7694 :
7695 1556 : gfc_start_block (&block);
7696 :
7697 1556 : memset (&loop_clauses, 0, sizeof (loop_clauses));
7698 1556 : if (code->ext.omp_clauses != NULL)
7699 : {
7700 1556 : memcpy (&construct_clauses, code->ext.omp_clauses,
7701 : sizeof (construct_clauses));
7702 1556 : loop_clauses.collapse = construct_clauses.collapse;
7703 1556 : loop_clauses.gang = construct_clauses.gang;
7704 1556 : loop_clauses.gang_static = construct_clauses.gang_static;
7705 1556 : loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
7706 1556 : loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
7707 1556 : loop_clauses.vector = construct_clauses.vector;
7708 1556 : loop_clauses.vector_expr = construct_clauses.vector_expr;
7709 1556 : loop_clauses.worker = construct_clauses.worker;
7710 1556 : loop_clauses.worker_expr = construct_clauses.worker_expr;
7711 1556 : loop_clauses.seq = construct_clauses.seq;
7712 1556 : loop_clauses.par_auto = construct_clauses.par_auto;
7713 1556 : loop_clauses.independent = construct_clauses.independent;
7714 1556 : loop_clauses.tile_list = construct_clauses.tile_list;
7715 1556 : loop_clauses.lists[OMP_LIST_PRIVATE]
7716 1556 : = construct_clauses.lists[OMP_LIST_PRIVATE];
7717 1556 : loop_clauses.lists[OMP_LIST_REDUCTION]
7718 1556 : = construct_clauses.lists[OMP_LIST_REDUCTION];
7719 1556 : construct_clauses.gang = false;
7720 1556 : construct_clauses.gang_static = false;
7721 1556 : construct_clauses.gang_num_expr = NULL;
7722 1556 : construct_clauses.gang_static_expr = NULL;
7723 1556 : construct_clauses.vector = false;
7724 1556 : construct_clauses.vector_expr = NULL;
7725 1556 : construct_clauses.worker = false;
7726 1556 : construct_clauses.worker_expr = NULL;
7727 1556 : construct_clauses.seq = false;
7728 1556 : construct_clauses.par_auto = false;
7729 1556 : construct_clauses.independent = false;
7730 1556 : construct_clauses.independent = false;
7731 1556 : construct_clauses.tile_list = NULL;
7732 1556 : construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
7733 1556 : if (construct_code == OACC_KERNELS)
7734 87 : construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
7735 1556 : oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
7736 : code->loc, false, true);
7737 : }
7738 1556 : if (!loop_clauses.seq)
7739 : pblock = █
7740 : else
7741 54 : pushlevel ();
7742 1556 : stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL);
7743 1556 : protected_set_expr_location (stmt, loc);
7744 1556 : if (TREE_CODE (stmt) != BIND_EXPR)
7745 1556 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
7746 : else
7747 0 : poplevel (0, 0);
7748 1556 : stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses);
7749 1556 : gfc_add_expr_to_block (&block, stmt);
7750 1556 : return gfc_finish_block (&block);
7751 : }
7752 :
7753 : static tree
7754 108 : gfc_trans_omp_depobj (gfc_code *code)
7755 : {
7756 108 : stmtblock_t block;
7757 108 : gfc_se se;
7758 108 : gfc_init_se (&se, NULL);
7759 108 : gfc_init_block (&block);
7760 108 : gfc_conv_expr (&se, code->ext.omp_clauses->depobj);
7761 108 : gcc_assert (se.pre.head == NULL && se.post.head == NULL);
7762 108 : tree depobj = se.expr;
7763 108 : location_t loc = EXPR_LOCATION (depobj);
7764 108 : if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
7765 108 : depobj = gfc_build_addr_expr (NULL, depobj);
7766 108 : depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
7767 : TYPE_MODE (ptr_type_node),
7768 : true), depobj);
7769 108 : gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
7770 108 : if (n)
7771 : {
7772 83 : tree var;
7773 83 : if (!n->sym) /* omp_all_memory. */
7774 3 : var = null_pointer_node;
7775 80 : else if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
7776 : {
7777 18 : gfc_init_se (&se, NULL);
7778 18 : if (n->expr->rank == 0)
7779 : {
7780 18 : gfc_conv_expr_reference (&se, n->expr);
7781 18 : var = se.expr;
7782 : }
7783 : else
7784 : {
7785 0 : gfc_conv_expr_descriptor (&se, n->expr);
7786 0 : var = gfc_conv_array_data (se.expr);
7787 : }
7788 18 : gfc_add_block_to_block (&block, &se.pre);
7789 18 : gfc_add_block_to_block (&block, &se.post);
7790 18 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7791 : }
7792 : else
7793 : {
7794 62 : var = gfc_get_symbol_decl (n->sym);
7795 99 : if (POINTER_TYPE_P (TREE_TYPE (var))
7796 72 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
7797 8 : var = build_fold_indirect_ref (var);
7798 62 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
7799 : {
7800 12 : var = gfc_conv_descriptor_data_get (var);
7801 12 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
7802 : }
7803 50 : else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
7804 13 : && n->sym->attr.dummy)
7805 8 : var = build_fold_indirect_ref (var);
7806 67 : else if (!POINTER_TYPE_P (TREE_TYPE (var))
7807 44 : || (n->sym->ts.f90_type == BT_VOID
7808 12 : && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
7809 8 : && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
7810 : {
7811 29 : TREE_ADDRESSABLE (var) = 1;
7812 29 : var = gfc_build_addr_expr (NULL, var);
7813 : }
7814 : }
7815 83 : depobj = save_expr (depobj);
7816 83 : tree r = build_fold_indirect_ref_loc (loc, depobj);
7817 83 : gfc_add_expr_to_block (&block,
7818 : build2 (MODIFY_EXPR, void_type_node, r, var));
7819 : }
7820 :
7821 : /* Only one may be set. */
7822 108 : gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
7823 : + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
7824 : == 1);
7825 108 : int k = -1; /* omp_clauses->destroy */
7826 108 : if (!code->ext.omp_clauses->destroy)
7827 92 : switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
7828 92 : ? code->ext.omp_clauses->depobj_update : n->u.depend_doacross_op)
7829 : {
7830 : case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
7831 : case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
7832 : case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
7833 : case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break;
7834 : case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
7835 0 : default: gcc_unreachable ();
7836 : }
7837 108 : tree t = build_int_cst (ptr_type_node, k);
7838 108 : depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj,
7839 108 : TYPE_SIZE_UNIT (ptr_type_node));
7840 108 : depobj = build_fold_indirect_ref_loc (loc, depobj);
7841 108 : gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
7842 :
7843 108 : return gfc_finish_block (&block);
7844 : }
7845 :
7846 : /* Callback for walk_tree to find an OMP dispatch call and wrap it into an
7847 : * IFN_GOMP_DISPATCH. */
7848 :
7849 : static tree
7850 2066 : replace_omp_dispatch_call (tree *tp, int *, void *decls_p)
7851 : {
7852 2066 : tree t = *tp;
7853 2066 : tree decls = (tree) decls_p;
7854 2066 : tree orig_fn_decl = TREE_PURPOSE (decls);
7855 2066 : tree dup_fn_decl = TREE_VALUE (decls);
7856 2066 : if (TREE_CODE (t) == CALL_EXPR)
7857 : {
7858 141 : if (CALL_EXPR_FN (t) == dup_fn_decl)
7859 1 : CALL_EXPR_FN (t) = orig_fn_decl;
7860 140 : else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR
7861 140 : && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl)
7862 127 : TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl;
7863 : else
7864 : return NULL_TREE;
7865 128 : *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH,
7866 128 : TREE_TYPE (t), 1, t);
7867 128 : return *tp;
7868 : }
7869 :
7870 : return NULL_TREE;
7871 : }
7872 :
7873 : static tree
7874 128 : gfc_trans_omp_dispatch (gfc_code *code)
7875 : {
7876 128 : stmtblock_t block;
7877 128 : gfc_code *next = code->block->next;
7878 : // assume ill-formed "function dispatch structured
7879 : // block" have already been rejected by resolve_omp_dispatch
7880 128 : gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
7881 :
7882 : // Make duplicate decl for dispatch function call to make it easy to spot
7883 : // after translation
7884 128 : gfc_symbol *orig_fn_sym;
7885 128 : gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2;
7886 128 : if (call_expr != NULL) // function
7887 : {
7888 71 : if (call_expr->value.function.isym != NULL) // dig into convert intrinsics
7889 4 : call_expr = call_expr->value.function.actual->expr;
7890 71 : gcc_assert (call_expr->expr_type == EXPR_FUNCTION);
7891 71 : orig_fn_sym = call_expr->value.function.esym
7892 71 : ? call_expr->value.function.esym
7893 0 : : call_expr->symtree->n.sym;
7894 : }
7895 : else // subroutine
7896 : {
7897 57 : orig_fn_sym = next->resolved_sym;
7898 : }
7899 128 : if (!orig_fn_sym->backend_decl)
7900 25 : gfc_get_symbol_decl (orig_fn_sym);
7901 128 : gfc_symbol dup_fn_sym = *orig_fn_sym;
7902 128 : dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl);
7903 128 : if (call_expr != NULL)
7904 71 : call_expr->value.function.esym = &dup_fn_sym;
7905 : else
7906 57 : next->resolved_sym = &dup_fn_sym;
7907 :
7908 128 : tree body = gfc_trans_code (next);
7909 :
7910 : // Walk the tree to find the duplicate decl, wrap IFN call and replace
7911 : // dup decl with original
7912 128 : tree fn_decls
7913 128 : = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl);
7914 128 : tree dispatch_call
7915 128 : = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL);
7916 128 : gcc_assert (dispatch_call != NULL_TREE);
7917 :
7918 128 : gfc_start_block (&block);
7919 128 : tree omp_clauses
7920 128 : = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
7921 :
7922 : // Extract depend clauses and create taskwait
7923 128 : tree depend_clauses = NULL_TREE;
7924 128 : tree *depend_clauses_ptr = &depend_clauses;
7925 333 : for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c))
7926 : {
7927 205 : if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND)
7928 : {
7929 8 : *depend_clauses_ptr = c;
7930 8 : depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c);
7931 : }
7932 : }
7933 128 : if (depend_clauses != NULL_TREE)
7934 : {
7935 4 : tree stmt = make_node (OMP_TASK);
7936 4 : TREE_TYPE (stmt) = void_node;
7937 4 : OMP_TASK_CLAUSES (stmt) = depend_clauses;
7938 4 : OMP_TASK_BODY (stmt) = NULL_TREE;
7939 4 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7940 4 : gfc_add_expr_to_block (&block, stmt);
7941 : }
7942 :
7943 128 : tree stmt = make_node (OMP_DISPATCH);
7944 128 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
7945 128 : TREE_TYPE (stmt) = void_type_node;
7946 128 : OMP_DISPATCH_BODY (stmt) = body;
7947 128 : OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
7948 :
7949 128 : gfc_add_expr_to_block (&block, stmt);
7950 128 : return gfc_finish_block (&block);
7951 : }
7952 :
7953 : static tree
7954 29 : gfc_trans_omp_error (gfc_code *code)
7955 : {
7956 29 : stmtblock_t block;
7957 29 : gfc_se se;
7958 29 : tree len, message;
7959 29 : bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
7960 42 : tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
7961 : : BUILT_IN_GOMP_WARNING);
7962 29 : gfc_start_block (&block);
7963 29 : gfc_init_se (&se, NULL );
7964 29 : if (!code->ext.omp_clauses->message)
7965 : {
7966 3 : message = null_pointer_node;
7967 3 : len = build_int_cst (size_type_node, 0);
7968 : }
7969 : else
7970 : {
7971 26 : gfc_conv_expr (&se, code->ext.omp_clauses->message);
7972 26 : message = se.expr;
7973 26 : if (!POINTER_TYPE_P (TREE_TYPE (message)))
7974 : /* To ensure an ARRAY_TYPE is not passed as such. */
7975 17 : message = gfc_build_addr_expr (NULL, message);
7976 26 : len = se.string_length;
7977 : }
7978 29 : gfc_add_block_to_block (&block, &se.pre);
7979 29 : gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
7980 : 2, message, len));
7981 29 : gfc_add_block_to_block (&block, &se.post);
7982 29 : return gfc_finish_block (&block);
7983 : }
7984 :
7985 : static tree
7986 70 : gfc_trans_omp_flush (gfc_code *code)
7987 : {
7988 70 : tree call;
7989 70 : if (!code->ext.omp_clauses
7990 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
7991 4 : || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
7992 : {
7993 67 : call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
7994 67 : call = build_call_expr_loc (input_location, call, 0);
7995 : }
7996 : else
7997 : {
7998 3 : enum memmodel mo = MEMMODEL_LAST;
7999 3 : switch (code->ext.omp_clauses->memorder)
8000 : {
8001 : case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
8002 : case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
8003 : case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
8004 0 : default: gcc_unreachable (); break;
8005 : }
8006 3 : call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE);
8007 3 : call = build_call_expr_loc (input_location, call, 1,
8008 3 : build_int_cst (integer_type_node, mo));
8009 : }
8010 70 : return call;
8011 : }
8012 :
8013 : static tree
8014 116 : gfc_trans_omp_master (gfc_code *code)
8015 : {
8016 116 : tree stmt = gfc_trans_code (code->block->next);
8017 116 : if (IS_EMPTY_STMT (stmt))
8018 : return stmt;
8019 110 : return build1_v (OMP_MASTER, stmt);
8020 : }
8021 :
8022 : static tree
8023 55 : gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
8024 : {
8025 55 : stmtblock_t block;
8026 55 : tree body = gfc_trans_code (code->block->next);
8027 55 : if (IS_EMPTY_STMT (body))
8028 : return body;
8029 46 : if (!clauses)
8030 39 : clauses = code->ext.omp_clauses;
8031 46 : gfc_start_block (&block);
8032 46 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
8033 46 : tree stmt = make_node (OMP_MASKED);
8034 46 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8035 46 : TREE_TYPE (stmt) = void_type_node;
8036 46 : OMP_MASKED_BODY (stmt) = body;
8037 46 : OMP_MASKED_CLAUSES (stmt) = omp_clauses;
8038 46 : gfc_add_expr_to_block (&block, stmt);
8039 46 : return gfc_finish_block (&block);
8040 : }
8041 :
8042 :
8043 : static tree
8044 521 : gfc_trans_omp_ordered (gfc_code *code)
8045 : {
8046 521 : if (!flag_openmp)
8047 : {
8048 5 : if (!code->ext.omp_clauses->simd)
8049 3 : return gfc_trans_code (code->block ? code->block->next : NULL);
8050 2 : code->ext.omp_clauses->threads = 0;
8051 : }
8052 518 : tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
8053 : code->loc);
8054 518 : return build2_loc (input_location, OMP_ORDERED, void_type_node,
8055 518 : code->block ? gfc_trans_code (code->block->next)
8056 518 : : NULL_TREE, omp_clauses);
8057 : }
8058 :
8059 : static tree
8060 1854 : gfc_trans_omp_parallel (gfc_code *code)
8061 : {
8062 1854 : stmtblock_t block;
8063 1854 : tree stmt, omp_clauses;
8064 :
8065 1854 : gfc_start_block (&block);
8066 1854 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8067 : code->loc);
8068 1854 : pushlevel ();
8069 1854 : stmt = gfc_trans_omp_code (code->block->next, true);
8070 1854 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8071 1854 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
8072 : omp_clauses);
8073 1854 : gfc_add_expr_to_block (&block, stmt);
8074 1854 : return gfc_finish_block (&block);
8075 : }
8076 :
8077 : enum
8078 : {
8079 : GFC_OMP_SPLIT_SIMD,
8080 : GFC_OMP_SPLIT_DO,
8081 : GFC_OMP_SPLIT_PARALLEL,
8082 : GFC_OMP_SPLIT_DISTRIBUTE,
8083 : GFC_OMP_SPLIT_TEAMS,
8084 : GFC_OMP_SPLIT_TARGET,
8085 : GFC_OMP_SPLIT_TASKLOOP,
8086 : GFC_OMP_SPLIT_MASKED,
8087 : GFC_OMP_SPLIT_NUM
8088 : };
8089 :
8090 : enum
8091 : {
8092 : GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
8093 : GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
8094 : GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL),
8095 : GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE),
8096 : GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS),
8097 : GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET),
8098 : GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
8099 : GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
8100 : };
8101 :
8102 : /* If a var is in lastprivate/firstprivate/reduction but not in a
8103 : data mapping/sharing clause, add it to 'map(tofrom:' if is_target
8104 : and to 'shared' otherwise. */
8105 : static void
8106 2538 : gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
8107 : gfc_omp_clauses *clauses_in,
8108 : bool is_target, bool is_parallel_do)
8109 : {
8110 2538 : int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
8111 2538 : gfc_omp_namelist *tail = NULL;
8112 15228 : for (int i = 0; i < 5; ++i)
8113 : {
8114 12690 : gfc_omp_namelist *n;
8115 12690 : switch (i)
8116 : {
8117 2538 : case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
8118 2538 : case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
8119 2538 : case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
8120 2538 : case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
8121 2538 : case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
8122 : default: gcc_unreachable ();
8123 : }
8124 16016 : for (; n != NULL; n = n->next)
8125 : {
8126 : gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
8127 20586 : for (int j = 0; j < 6; ++j)
8128 : {
8129 18127 : gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
8130 18127 : switch (j)
8131 : {
8132 3326 : case 0:
8133 3326 : n2ref = &clauses_out->lists[clauselist_to_add];
8134 3326 : break;
8135 3289 : case 1:
8136 3289 : n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
8137 3289 : break;
8138 3289 : case 2:
8139 3289 : if (is_target)
8140 256 : n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
8141 : else
8142 3033 : n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
8143 : break;
8144 3289 : case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
8145 2467 : case 4:
8146 2467 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
8147 2467 : break;
8148 2467 : case 5:
8149 2467 : n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
8150 2467 : break;
8151 : default: gcc_unreachable ();
8152 : }
8153 28365 : for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
8154 13488 : if (n2->sym == n->sym)
8155 : break;
8156 18127 : if (n2)
8157 : {
8158 3250 : if (j == 0 /* clauselist_to_add */)
8159 : break; /* Already present. */
8160 3213 : if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
8161 : {
8162 1122 : n_firstp = prev2 ? &prev2->next : n2ref;
8163 1122 : continue;
8164 : }
8165 2091 : if (j == 2 /* OMP_LIST_LASTPRIVATE */)
8166 : {
8167 1261 : n_lastp = prev2 ? &prev2->next : n2ref;
8168 1261 : continue;
8169 : }
8170 : break;
8171 : }
8172 : }
8173 3326 : if (n_firstp && n_lastp)
8174 : {
8175 : /* For parallel do, GCC puts firstprivate/lastprivate
8176 : on the parallel. */
8177 283 : if (is_parallel_do)
8178 280 : continue;
8179 3 : *n_firstp = (*n_firstp)->next;
8180 3 : if (!is_target)
8181 0 : *n_lastp = (*n_lastp)->next;
8182 : }
8183 3043 : else if (is_target && n_lastp)
8184 : ;
8185 2988 : else if (n2 || n_firstp || n_lastp)
8186 2629 : continue;
8187 417 : if (clauses_out->lists[clauselist_to_add]
8188 305 : && (clauses_out->lists[clauselist_to_add]
8189 305 : == clauses_in->lists[clauselist_to_add]))
8190 : {
8191 : gfc_omp_namelist *p = NULL;
8192 421 : for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
8193 : {
8194 273 : if (p)
8195 : {
8196 125 : p->next = gfc_get_omp_namelist ();
8197 125 : p = p->next;
8198 : }
8199 : else
8200 : {
8201 148 : p = gfc_get_omp_namelist ();
8202 148 : clauses_out->lists[clauselist_to_add] = p;
8203 : }
8204 273 : *p = *n2;
8205 : }
8206 : }
8207 417 : if (!tail)
8208 : {
8209 288 : tail = clauses_out->lists[clauselist_to_add];
8210 413 : for (; tail && tail->next; tail = tail->next)
8211 : ;
8212 : }
8213 417 : n2 = gfc_get_omp_namelist ();
8214 417 : n2->where = n->where;
8215 417 : n2->sym = n->sym;
8216 417 : if (is_target)
8217 120 : n2->u.map.op = OMP_MAP_TOFROM;
8218 417 : if (tail)
8219 : {
8220 305 : tail->next = n2;
8221 305 : tail = n2;
8222 : }
8223 : else
8224 112 : clauses_out->lists[clauselist_to_add] = n2;
8225 : }
8226 : }
8227 2538 : }
8228 :
8229 : /* Kind of opposite to above, add firstprivate to CLAUSES_OUT if it is mapped
8230 : in CLAUSES_IN's FIRSTPRIVATE list but not its MAP list. */
8231 :
8232 : static void
8233 345 : gfc_add_firstprivate_if_unmapped (gfc_omp_clauses *clauses_out,
8234 : gfc_omp_clauses *clauses_in)
8235 : {
8236 345 : gfc_omp_namelist *n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE];
8237 345 : gfc_omp_namelist **tail = NULL;
8238 :
8239 495 : for (; n != NULL; n = n->next)
8240 : {
8241 150 : gfc_omp_namelist *n2 = clauses_out->lists[OMP_LIST_MAP];
8242 192 : for (; n2 != NULL; n2 = n2->next)
8243 53 : if (n->sym == n2->sym)
8244 : break;
8245 150 : if (n2 == NULL)
8246 : {
8247 139 : gfc_omp_namelist *dup = gfc_get_omp_namelist ();
8248 139 : *dup = *n;
8249 139 : dup->next = NULL;
8250 139 : if (!tail)
8251 : {
8252 76 : tail = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
8253 76 : while (*tail && (*tail)->next)
8254 0 : tail = &(*tail)->next;
8255 : }
8256 139 : *tail = dup;
8257 139 : tail = &(*tail)->next;
8258 : }
8259 : }
8260 345 : }
8261 :
8262 : static void
8263 4423 : gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
8264 : {
8265 39807 : for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
8266 1415360 : for (int j = 0; j < OMP_LIST_NUM; ++j)
8267 1379976 : if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
8268 1357 : for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
8269 : {
8270 927 : gfc_omp_namelist *p = n;
8271 927 : n = n->next;
8272 927 : free (p);
8273 : }
8274 4423 : }
8275 :
8276 : static void
8277 4423 : gfc_split_omp_clauses (gfc_code *code,
8278 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
8279 : {
8280 4423 : int mask = 0, innermost = 0;
8281 4423 : bool is_loop = false;
8282 4423 : memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
8283 4423 : switch (code->op)
8284 : {
8285 : case EXEC_OMP_DISTRIBUTE:
8286 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8287 : break;
8288 38 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8289 38 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8290 38 : innermost = GFC_OMP_SPLIT_DO;
8291 38 : break;
8292 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8293 28 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL
8294 : | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8295 28 : innermost = GFC_OMP_SPLIT_SIMD;
8296 28 : break;
8297 47 : case EXEC_OMP_DISTRIBUTE_SIMD:
8298 47 : mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8299 47 : innermost = GFC_OMP_SPLIT_SIMD;
8300 47 : break;
8301 0 : case EXEC_OMP_DO:
8302 0 : case EXEC_OMP_LOOP:
8303 0 : innermost = GFC_OMP_SPLIT_DO;
8304 0 : break;
8305 126 : case EXEC_OMP_DO_SIMD:
8306 126 : mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8307 126 : innermost = GFC_OMP_SPLIT_SIMD;
8308 126 : break;
8309 0 : case EXEC_OMP_PARALLEL:
8310 0 : innermost = GFC_OMP_SPLIT_PARALLEL;
8311 0 : break;
8312 1106 : case EXEC_OMP_PARALLEL_DO:
8313 1106 : case EXEC_OMP_PARALLEL_LOOP:
8314 1106 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8315 1106 : innermost = GFC_OMP_SPLIT_DO;
8316 1106 : break;
8317 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
8318 285 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8319 285 : innermost = GFC_OMP_SPLIT_SIMD;
8320 285 : break;
8321 11 : case EXEC_OMP_PARALLEL_MASKED:
8322 11 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
8323 11 : innermost = GFC_OMP_SPLIT_MASKED;
8324 11 : break;
8325 14 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8326 14 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
8327 : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
8328 14 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8329 14 : break;
8330 20 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8331 20 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8332 20 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8333 20 : break;
8334 24 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8335 24 : mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
8336 : | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
8337 24 : innermost = GFC_OMP_SPLIT_SIMD;
8338 24 : break;
8339 28 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8340 28 : mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8341 28 : innermost = GFC_OMP_SPLIT_SIMD;
8342 28 : break;
8343 0 : case EXEC_OMP_SIMD:
8344 0 : innermost = GFC_OMP_SPLIT_SIMD;
8345 0 : break;
8346 2015 : case EXEC_OMP_TARGET:
8347 2015 : innermost = GFC_OMP_SPLIT_TARGET;
8348 2015 : break;
8349 23 : case EXEC_OMP_TARGET_PARALLEL:
8350 23 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
8351 23 : innermost = GFC_OMP_SPLIT_PARALLEL;
8352 23 : break;
8353 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
8354 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8355 80 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8356 80 : innermost = GFC_OMP_SPLIT_DO;
8357 80 : break;
8358 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8359 15 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
8360 : | GFC_OMP_MASK_SIMD;
8361 15 : innermost = GFC_OMP_SPLIT_SIMD;
8362 15 : break;
8363 26 : case EXEC_OMP_TARGET_SIMD:
8364 26 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
8365 26 : innermost = GFC_OMP_SPLIT_SIMD;
8366 26 : break;
8367 71 : case EXEC_OMP_TARGET_TEAMS:
8368 71 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS;
8369 71 : innermost = GFC_OMP_SPLIT_TEAMS;
8370 71 : break;
8371 14 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8372 14 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
8373 : | GFC_OMP_MASK_DISTRIBUTE;
8374 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8375 14 : break;
8376 58 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8377 58 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8378 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8379 58 : innermost = GFC_OMP_SPLIT_DO;
8380 58 : break;
8381 29 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8382 29 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8383 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8384 29 : innermost = GFC_OMP_SPLIT_SIMD;
8385 29 : break;
8386 16 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8387 16 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS
8388 : | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8389 16 : innermost = GFC_OMP_SPLIT_SIMD;
8390 16 : break;
8391 13 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8392 13 : mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
8393 13 : innermost = GFC_OMP_SPLIT_DO;
8394 13 : break;
8395 8 : case EXEC_OMP_MASKED_TASKLOOP:
8396 8 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
8397 8 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8398 8 : break;
8399 0 : case EXEC_OMP_MASTER_TASKLOOP:
8400 0 : case EXEC_OMP_TASKLOOP:
8401 0 : innermost = GFC_OMP_SPLIT_TASKLOOP;
8402 0 : break;
8403 24 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8404 24 : mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8405 24 : innermost = GFC_OMP_SPLIT_SIMD;
8406 24 : break;
8407 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8408 45 : case EXEC_OMP_TASKLOOP_SIMD:
8409 45 : mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
8410 45 : innermost = GFC_OMP_SPLIT_SIMD;
8411 45 : break;
8412 114 : case EXEC_OMP_TEAMS:
8413 114 : innermost = GFC_OMP_SPLIT_TEAMS;
8414 114 : break;
8415 14 : case EXEC_OMP_TEAMS_DISTRIBUTE:
8416 14 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE;
8417 14 : innermost = GFC_OMP_SPLIT_DISTRIBUTE;
8418 14 : break;
8419 32 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8420 32 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8421 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
8422 32 : innermost = GFC_OMP_SPLIT_DO;
8423 32 : break;
8424 56 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8425 56 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE
8426 : | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
8427 56 : innermost = GFC_OMP_SPLIT_SIMD;
8428 56 : break;
8429 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8430 37 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD;
8431 37 : innermost = GFC_OMP_SPLIT_SIMD;
8432 37 : break;
8433 : case EXEC_OMP_TEAMS_LOOP:
8434 : mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
8435 : innermost = GFC_OMP_SPLIT_DO;
8436 : break;
8437 0 : default:
8438 0 : gcc_unreachable ();
8439 : }
8440 4417 : if (mask == 0)
8441 : {
8442 2129 : clausesa[innermost] = *code->ext.omp_clauses;
8443 2129 : return;
8444 : }
8445 : /* Loops are similar to DO but still a bit different. */
8446 2294 : switch (code->op)
8447 : {
8448 54 : case EXEC_OMP_LOOP:
8449 54 : case EXEC_OMP_PARALLEL_LOOP:
8450 54 : case EXEC_OMP_TEAMS_LOOP:
8451 54 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8452 54 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8453 54 : is_loop = true;
8454 2294 : default:
8455 2294 : break;
8456 : }
8457 2294 : if (code->ext.omp_clauses != NULL)
8458 : {
8459 2294 : if (mask & GFC_OMP_MASK_TARGET)
8460 : {
8461 : /* First the clauses that are unique to some constructs. */
8462 345 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP]
8463 345 : = code->ext.omp_clauses->lists[OMP_LIST_MAP];
8464 345 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR]
8465 345 : = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
8466 345 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_HAS_DEVICE_ADDR]
8467 345 : = code->ext.omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
8468 345 : clausesa[GFC_OMP_SPLIT_TARGET].device
8469 345 : = code->ext.omp_clauses->device;
8470 345 : clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
8471 345 : = code->ext.omp_clauses->thread_limit;
8472 345 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
8473 345 : = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
8474 2415 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
8475 2070 : clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
8476 2070 : = code->ext.omp_clauses->defaultmap[i];
8477 345 : clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
8478 345 : = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
8479 : /* And this is copied to all. */
8480 345 : clausesa[GFC_OMP_SPLIT_TARGET].if_expr
8481 345 : = code->ext.omp_clauses->if_expr;
8482 345 : clausesa[GFC_OMP_SPLIT_TARGET].nowait
8483 345 : = code->ext.omp_clauses->nowait;
8484 345 : clausesa[GFC_OMP_SPLIT_TARGET].device_type
8485 345 : = code->ext.omp_clauses->device_type;
8486 : }
8487 2294 : if (mask & GFC_OMP_MASK_TEAMS)
8488 : {
8489 : /* First the clauses that are unique to some constructs. */
8490 346 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
8491 346 : = code->ext.omp_clauses->num_teams_lower;
8492 346 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
8493 346 : = code->ext.omp_clauses->num_teams_upper;
8494 346 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
8495 346 : = code->ext.omp_clauses->thread_limit;
8496 : /* Shared and default clauses are allowed on parallel, teams
8497 : and taskloop. */
8498 346 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED]
8499 346 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8500 346 : clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing
8501 346 : = code->ext.omp_clauses->default_sharing;
8502 : }
8503 2294 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8504 : {
8505 : /* First the clauses that are unique to some constructs. */
8506 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind
8507 369 : = code->ext.omp_clauses->dist_sched_kind;
8508 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size
8509 369 : = code->ext.omp_clauses->dist_chunk_size;
8510 : /* Duplicate collapse. */
8511 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse
8512 369 : = code->ext.omp_clauses->collapse;
8513 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
8514 369 : = code->ext.omp_clauses->order_concurrent;
8515 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
8516 369 : = code->ext.omp_clauses->order_unconstrained;
8517 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
8518 369 : = code->ext.omp_clauses->order_reproducible;
8519 : }
8520 2294 : if (mask & GFC_OMP_MASK_PARALLEL)
8521 : {
8522 : /* First the clauses that are unique to some constructs. */
8523 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
8524 1847 : = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
8525 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
8526 1847 : = code->ext.omp_clauses->num_threads;
8527 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
8528 1847 : = code->ext.omp_clauses->proc_bind;
8529 : /* Shared and default clauses are allowed on parallel, teams
8530 : and taskloop. */
8531 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
8532 1847 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8533 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
8534 1847 : = code->ext.omp_clauses->default_sharing;
8535 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
8536 1847 : = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
8537 : /* And this is copied to all. */
8538 1847 : clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
8539 1847 : = code->ext.omp_clauses->if_expr;
8540 : }
8541 2294 : if (mask & GFC_OMP_MASK_MASKED)
8542 81 : clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
8543 2294 : if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8544 : {
8545 : /* First the clauses that are unique to some constructs. */
8546 1818 : clausesa[GFC_OMP_SPLIT_DO].ordered
8547 1818 : = code->ext.omp_clauses->ordered;
8548 1818 : clausesa[GFC_OMP_SPLIT_DO].orderedc
8549 1818 : = code->ext.omp_clauses->orderedc;
8550 1818 : clausesa[GFC_OMP_SPLIT_DO].sched_kind
8551 1818 : = code->ext.omp_clauses->sched_kind;
8552 1818 : if (innermost == GFC_OMP_SPLIT_SIMD)
8553 539 : clausesa[GFC_OMP_SPLIT_DO].sched_simd
8554 539 : = code->ext.omp_clauses->sched_simd;
8555 1818 : clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
8556 1818 : = code->ext.omp_clauses->sched_monotonic;
8557 1818 : clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
8558 1818 : = code->ext.omp_clauses->sched_nonmonotonic;
8559 1818 : clausesa[GFC_OMP_SPLIT_DO].chunk_size
8560 1818 : = code->ext.omp_clauses->chunk_size;
8561 1818 : clausesa[GFC_OMP_SPLIT_DO].nowait
8562 1818 : = code->ext.omp_clauses->nowait;
8563 : }
8564 1872 : if (mask & GFC_OMP_MASK_DO)
8565 : {
8566 1872 : clausesa[GFC_OMP_SPLIT_DO].bind
8567 1872 : = code->ext.omp_clauses->bind;
8568 : /* Duplicate collapse. */
8569 1872 : clausesa[GFC_OMP_SPLIT_DO].collapse
8570 1872 : = code->ext.omp_clauses->collapse;
8571 1872 : clausesa[GFC_OMP_SPLIT_DO].order_concurrent
8572 1872 : = code->ext.omp_clauses->order_concurrent;
8573 1872 : clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
8574 1872 : = code->ext.omp_clauses->order_unconstrained;
8575 1872 : clausesa[GFC_OMP_SPLIT_DO].order_reproducible
8576 1872 : = code->ext.omp_clauses->order_reproducible;
8577 : }
8578 2294 : if (mask & GFC_OMP_MASK_SIMD)
8579 : {
8580 820 : clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
8581 820 : = code->ext.omp_clauses->safelen_expr;
8582 820 : clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
8583 820 : = code->ext.omp_clauses->simdlen_expr;
8584 820 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
8585 820 : = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
8586 : /* Duplicate collapse. */
8587 820 : clausesa[GFC_OMP_SPLIT_SIMD].collapse
8588 820 : = code->ext.omp_clauses->collapse;
8589 820 : clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
8590 820 : = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
8591 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
8592 820 : = code->ext.omp_clauses->order_concurrent;
8593 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
8594 820 : = code->ext.omp_clauses->order_unconstrained;
8595 820 : clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
8596 820 : = code->ext.omp_clauses->order_reproducible;
8597 : /* And this is copied to all. */
8598 820 : clausesa[GFC_OMP_SPLIT_SIMD].if_expr
8599 820 : = code->ext.omp_clauses->if_expr;
8600 : }
8601 2294 : if (mask & GFC_OMP_MASK_TASKLOOP)
8602 : {
8603 : /* First the clauses that are unique to some constructs. */
8604 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
8605 163 : = code->ext.omp_clauses->nogroup;
8606 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
8607 163 : = code->ext.omp_clauses->grainsize;
8608 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
8609 163 : = code->ext.omp_clauses->grainsize_strict;
8610 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
8611 163 : = code->ext.omp_clauses->num_tasks;
8612 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
8613 163 : = code->ext.omp_clauses->num_tasks_strict;
8614 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
8615 163 : = code->ext.omp_clauses->priority;
8616 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
8617 163 : = code->ext.omp_clauses->final_expr;
8618 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
8619 163 : = code->ext.omp_clauses->untied;
8620 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
8621 163 : = code->ext.omp_clauses->mergeable;
8622 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
8623 163 : = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
8624 : /* And this is copied to all. */
8625 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
8626 163 : = code->ext.omp_clauses->if_expr;
8627 : /* Shared and default clauses are allowed on parallel, teams
8628 : and taskloop. */
8629 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
8630 163 : = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
8631 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
8632 163 : = code->ext.omp_clauses->default_sharing;
8633 : /* Duplicate collapse. */
8634 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
8635 163 : = code->ext.omp_clauses->collapse;
8636 : }
8637 : /* Private clause is supported on all constructs but master/masked,
8638 : it is enough to put it on the innermost one except for master/masked. For
8639 : !$ omp parallel do put it on parallel though,
8640 : as that's what we did for OpenMP 3.1. */
8641 2294 : clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
8642 : || code->op == EXEC_OMP_PARALLEL_MASTER
8643 1015 : || code->op == EXEC_OMP_PARALLEL_MASKED)
8644 1004 : ? (int) GFC_OMP_SPLIT_PARALLEL
8645 3298 : : innermost].lists[OMP_LIST_PRIVATE]
8646 2294 : = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
8647 : /* Firstprivate clause is supported on all constructs but
8648 : simd and masked/master. Put it on the outermost of those and duplicate
8649 : on parallel and teams. */
8650 2294 : if (mask & GFC_OMP_MASK_TARGET)
8651 345 : gfc_add_firstprivate_if_unmapped (&clausesa[GFC_OMP_SPLIT_TARGET],
8652 : code->ext.omp_clauses);
8653 2294 : if (mask & GFC_OMP_MASK_TEAMS)
8654 346 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE]
8655 346 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8656 1948 : else if (mask & GFC_OMP_MASK_DISTRIBUTE)
8657 113 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE]
8658 113 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8659 2294 : if (mask & GFC_OMP_MASK_TASKLOOP)
8660 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
8661 163 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8662 2294 : if ((mask & GFC_OMP_MASK_PARALLEL)
8663 1847 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8664 1761 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
8665 1761 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8666 533 : else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
8667 126 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
8668 126 : = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
8669 : /* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
8670 : In parallel do{, simd} we actually want to put it on
8671 : parallel rather than do. */
8672 2294 : if (mask & GFC_OMP_MASK_DISTRIBUTE)
8673 369 : clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
8674 369 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8675 2294 : if (mask & GFC_OMP_MASK_TASKLOOP)
8676 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
8677 163 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8678 2294 : if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
8679 1812 : && !(mask & GFC_OMP_MASK_TASKLOOP))
8680 1726 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
8681 1726 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8682 568 : else if (mask & GFC_OMP_MASK_DO)
8683 180 : clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
8684 180 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8685 2294 : if (mask & GFC_OMP_MASK_SIMD)
8686 820 : clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
8687 820 : = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
8688 : /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
8689 : Duplicate it on all of them, but
8690 : - omit on do if parallel is present;
8691 : - omit on task and parallel if loop is present;
8692 : additionally, inscan applies to do/simd only. */
8693 9176 : for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
8694 : {
8695 6882 : if (mask & GFC_OMP_MASK_TASKLOOP
8696 489 : && i != OMP_LIST_REDUCTION_INSCAN)
8697 326 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
8698 326 : = code->ext.omp_clauses->lists[i];
8699 6882 : if (mask & GFC_OMP_MASK_TEAMS
8700 1038 : && i != OMP_LIST_REDUCTION_INSCAN
8701 1038 : && !is_loop)
8702 654 : clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
8703 654 : = code->ext.omp_clauses->lists[i];
8704 6882 : if (mask & GFC_OMP_MASK_PARALLEL
8705 5541 : && i != OMP_LIST_REDUCTION_INSCAN
8706 3694 : && !(mask & GFC_OMP_MASK_TASKLOOP)
8707 3522 : && !is_loop)
8708 3452 : clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
8709 3452 : = code->ext.omp_clauses->lists[i];
8710 3430 : else if (mask & GFC_OMP_MASK_DO)
8711 2232 : clausesa[GFC_OMP_SPLIT_DO].lists[i]
8712 2232 : = code->ext.omp_clauses->lists[i];
8713 6882 : if (mask & GFC_OMP_MASK_SIMD)
8714 2460 : clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
8715 2460 : = code->ext.omp_clauses->lists[i];
8716 : }
8717 2294 : if (mask & GFC_OMP_MASK_TARGET)
8718 345 : clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
8719 345 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8720 2294 : if (mask & GFC_OMP_MASK_TASKLOOP)
8721 163 : clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
8722 163 : = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
8723 : /* Linear clause is supported on do and simd,
8724 : put it on the innermost one. */
8725 2294 : clausesa[innermost].lists[OMP_LIST_LINEAR]
8726 2294 : = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
8727 : }
8728 : /* Propagate firstprivate/lastprivate/reduction vars to
8729 : shared (parallel, teams) and map-tofrom (target). */
8730 2294 : if (mask & GFC_OMP_MASK_TARGET)
8731 345 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET],
8732 : code->ext.omp_clauses, true, false);
8733 2294 : if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
8734 1847 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL],
8735 : code->ext.omp_clauses, false,
8736 1847 : mask & GFC_OMP_MASK_DO);
8737 2294 : if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
8738 346 : gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS],
8739 : code->ext.omp_clauses, false, false);
8740 2294 : if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8741 : == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
8742 1727 : && !is_loop)
8743 1692 : clausesa[GFC_OMP_SPLIT_DO].nowait = true;
8744 :
8745 : /* Distribute allocate clause to do, parallel, distribute, teams, target
8746 : and taskloop. The code below iterates over variables in the
8747 : allocate list and checks if that available is also in any
8748 : privatization clause on those construct. If yes, then we add it
8749 : to the list of 'allocate'ed variables for that construct. If a
8750 : variable is found in none of them then we issue an error. */
8751 :
8752 2294 : if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
8753 : {
8754 : gfc_omp_namelist *alloc_nl, *priv_nl;
8755 : gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
8756 74 : for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
8757 145 : alloc_nl; alloc_nl = alloc_nl->next)
8758 : {
8759 : bool found = false;
8760 518 : for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
8761 : {
8762 : gfc_omp_namelist *p;
8763 : int list;
8764 17760 : for (list = 0; list < OMP_LIST_NUM; list++)
8765 : {
8766 17316 : switch (list)
8767 : {
8768 3996 : case OMP_LIST_PRIVATE:
8769 3996 : case OMP_LIST_FIRSTPRIVATE:
8770 3996 : case OMP_LIST_LASTPRIVATE:
8771 3996 : case OMP_LIST_REDUCTION:
8772 3996 : case OMP_LIST_REDUCTION_INSCAN:
8773 3996 : case OMP_LIST_REDUCTION_TASK:
8774 3996 : case OMP_LIST_IN_REDUCTION:
8775 3996 : case OMP_LIST_TASK_REDUCTION:
8776 3996 : case OMP_LIST_LINEAR:
8777 4322 : for (priv_nl = clausesa[i].lists[list]; priv_nl;
8778 326 : priv_nl = priv_nl->next)
8779 326 : if (alloc_nl->sym == priv_nl->sym)
8780 : {
8781 101 : found = true;
8782 101 : p = gfc_get_omp_namelist ();
8783 101 : p->sym = alloc_nl->sym;
8784 101 : p->expr = alloc_nl->expr;
8785 101 : p->u.align = alloc_nl->u.align;
8786 101 : p->u2.allocator = alloc_nl->u2.allocator;
8787 101 : p->where = alloc_nl->where;
8788 101 : if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
8789 : {
8790 97 : clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
8791 97 : tails[i] = p;
8792 : }
8793 : else
8794 : {
8795 4 : tails[i]->next = p;
8796 4 : tails[i] = tails[i]->next;
8797 : }
8798 : }
8799 : break;
8800 : default:
8801 : break;
8802 : }
8803 : }
8804 : }
8805 74 : if (!found)
8806 1 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
8807 : "in an explicit privatization clause",
8808 1 : alloc_nl->sym->name, &alloc_nl->where);
8809 : }
8810 : }
8811 : }
8812 :
8813 : static tree
8814 539 : gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
8815 : gfc_omp_clauses *clausesa, tree omp_clauses)
8816 : {
8817 539 : stmtblock_t block;
8818 539 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8819 539 : tree stmt, body, omp_do_clauses = NULL_TREE;
8820 539 : bool free_clausesa = false;
8821 :
8822 539 : if (pblock == NULL)
8823 411 : gfc_start_block (&block);
8824 : else
8825 128 : gfc_init_block (&block);
8826 :
8827 539 : if (clausesa == NULL)
8828 : {
8829 126 : clausesa = clausesa_buf;
8830 126 : gfc_split_omp_clauses (code, clausesa);
8831 126 : free_clausesa = true;
8832 : }
8833 539 : if (flag_openmp)
8834 534 : omp_do_clauses
8835 534 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
8836 667 : body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block,
8837 : &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
8838 539 : if (pblock == NULL)
8839 : {
8840 411 : if (TREE_CODE (body) != BIND_EXPR)
8841 411 : body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
8842 : else
8843 0 : poplevel (0, 0);
8844 : }
8845 128 : else if (TREE_CODE (body) != BIND_EXPR)
8846 128 : body = build3_v (BIND_EXPR, NULL, body, NULL_TREE);
8847 539 : if (flag_openmp)
8848 : {
8849 534 : stmt = make_node (OMP_FOR);
8850 534 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
8851 534 : TREE_TYPE (stmt) = void_type_node;
8852 534 : OMP_FOR_BODY (stmt) = body;
8853 534 : OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
8854 : }
8855 : else
8856 : stmt = body;
8857 539 : gfc_add_expr_to_block (&block, stmt);
8858 539 : if (free_clausesa)
8859 126 : gfc_free_split_omp_clauses (code, clausesa);
8860 539 : return gfc_finish_block (&block);
8861 : }
8862 :
8863 : static tree
8864 1314 : gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock,
8865 : gfc_omp_clauses *clausesa)
8866 : {
8867 1314 : stmtblock_t block, *new_pblock = pblock;
8868 1314 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8869 1314 : tree stmt, omp_clauses = NULL_TREE;
8870 1314 : bool free_clausesa = false;
8871 :
8872 1314 : if (pblock == NULL)
8873 1106 : gfc_start_block (&block);
8874 : else
8875 208 : gfc_init_block (&block);
8876 :
8877 1314 : if (clausesa == NULL)
8878 : {
8879 1106 : clausesa = clausesa_buf;
8880 1106 : gfc_split_omp_clauses (code, clausesa);
8881 1106 : free_clausesa = true;
8882 : }
8883 1314 : omp_clauses
8884 1314 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8885 : code->loc);
8886 1314 : if (pblock == NULL)
8887 : {
8888 1106 : if (!clausesa[GFC_OMP_SPLIT_DO].ordered
8889 1097 : && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
8890 : new_pblock = █
8891 : else
8892 65 : pushlevel ();
8893 : }
8894 2593 : stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO,
8895 : new_pblock, &clausesa[GFC_OMP_SPLIT_DO],
8896 : omp_clauses);
8897 1314 : if (pblock == NULL)
8898 : {
8899 1106 : if (TREE_CODE (stmt) != BIND_EXPR)
8900 1090 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8901 : else
8902 16 : poplevel (0, 0);
8903 : }
8904 208 : else if (TREE_CODE (stmt) != BIND_EXPR)
8905 208 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8906 1314 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8907 : void_type_node, stmt, omp_clauses);
8908 1314 : OMP_PARALLEL_COMBINED (stmt) = 1;
8909 1314 : gfc_add_expr_to_block (&block, stmt);
8910 1314 : if (free_clausesa)
8911 1106 : gfc_free_split_omp_clauses (code, clausesa);
8912 1314 : return gfc_finish_block (&block);
8913 : }
8914 :
8915 : static tree
8916 413 : gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock,
8917 : gfc_omp_clauses *clausesa)
8918 : {
8919 413 : stmtblock_t block;
8920 413 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
8921 413 : tree stmt, omp_clauses = NULL_TREE;
8922 413 : bool free_clausesa = false;
8923 :
8924 413 : if (pblock == NULL)
8925 285 : gfc_start_block (&block);
8926 : else
8927 128 : gfc_init_block (&block);
8928 :
8929 413 : if (clausesa == NULL)
8930 : {
8931 285 : clausesa = clausesa_buf;
8932 285 : gfc_split_omp_clauses (code, clausesa);
8933 285 : free_clausesa = true;
8934 : }
8935 413 : if (flag_openmp)
8936 410 : omp_clauses
8937 410 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
8938 : code->loc);
8939 413 : if (pblock == NULL)
8940 285 : pushlevel ();
8941 413 : stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses);
8942 413 : if (pblock == NULL)
8943 : {
8944 285 : if (TREE_CODE (stmt) != BIND_EXPR)
8945 214 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8946 : else
8947 71 : poplevel (0, 0);
8948 : }
8949 128 : else if (TREE_CODE (stmt) != BIND_EXPR)
8950 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE);
8951 413 : if (flag_openmp)
8952 : {
8953 410 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8954 : void_type_node, stmt, omp_clauses);
8955 410 : OMP_PARALLEL_COMBINED (stmt) = 1;
8956 : }
8957 413 : gfc_add_expr_to_block (&block, stmt);
8958 413 : if (free_clausesa)
8959 285 : gfc_free_split_omp_clauses (code, clausesa);
8960 413 : return gfc_finish_block (&block);
8961 : }
8962 :
8963 : static tree
8964 54 : gfc_trans_omp_parallel_sections (gfc_code *code)
8965 : {
8966 54 : stmtblock_t block;
8967 54 : gfc_omp_clauses section_clauses;
8968 54 : tree stmt, omp_clauses;
8969 :
8970 54 : memset (§ion_clauses, 0, sizeof (section_clauses));
8971 54 : section_clauses.nowait = true;
8972 :
8973 54 : gfc_start_block (&block);
8974 54 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
8975 : code->loc);
8976 54 : pushlevel ();
8977 54 : stmt = gfc_trans_omp_sections (code, §ion_clauses);
8978 54 : if (TREE_CODE (stmt) != BIND_EXPR)
8979 54 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
8980 : else
8981 0 : poplevel (0, 0);
8982 54 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
8983 : void_type_node, stmt, omp_clauses);
8984 54 : OMP_PARALLEL_COMBINED (stmt) = 1;
8985 54 : gfc_add_expr_to_block (&block, stmt);
8986 54 : return gfc_finish_block (&block);
8987 : }
8988 :
8989 : static tree
8990 50 : gfc_trans_omp_parallel_workshare (gfc_code *code)
8991 : {
8992 50 : stmtblock_t block;
8993 50 : gfc_omp_clauses workshare_clauses;
8994 50 : tree stmt, omp_clauses;
8995 :
8996 50 : memset (&workshare_clauses, 0, sizeof (workshare_clauses));
8997 50 : workshare_clauses.nowait = true;
8998 :
8999 50 : gfc_start_block (&block);
9000 50 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9001 : code->loc);
9002 50 : pushlevel ();
9003 50 : stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
9004 50 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9005 50 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
9006 : void_type_node, stmt, omp_clauses);
9007 50 : OMP_PARALLEL_COMBINED (stmt) = 1;
9008 50 : gfc_add_expr_to_block (&block, stmt);
9009 50 : return gfc_finish_block (&block);
9010 : }
9011 :
9012 : static tree
9013 53 : gfc_trans_omp_scope (gfc_code *code)
9014 : {
9015 53 : stmtblock_t block;
9016 53 : tree body = gfc_trans_code (code->block->next);
9017 53 : if (IS_EMPTY_STMT (body))
9018 : return body;
9019 51 : gfc_start_block (&block);
9020 51 : tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9021 : code->loc);
9022 51 : tree stmt = make_node (OMP_SCOPE);
9023 51 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
9024 51 : TREE_TYPE (stmt) = void_type_node;
9025 51 : OMP_SCOPE_BODY (stmt) = body;
9026 51 : OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
9027 51 : gfc_add_expr_to_block (&block, stmt);
9028 51 : return gfc_finish_block (&block);
9029 : }
9030 :
9031 : static tree
9032 129 : gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
9033 : {
9034 129 : stmtblock_t block, body;
9035 129 : tree omp_clauses, stmt;
9036 129 : bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
9037 129 : location_t loc = gfc_get_location (&code->loc);
9038 :
9039 129 : gfc_start_block (&block);
9040 :
9041 129 : omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
9042 :
9043 129 : gfc_init_block (&body);
9044 499 : for (code = code->block; code; code = code->block)
9045 : {
9046 : /* Last section is special because of lastprivate, so even if it
9047 : is empty, chain it in. */
9048 370 : stmt = gfc_trans_omp_code (code->next,
9049 370 : has_lastprivate && code->block == NULL);
9050 370 : if (! IS_EMPTY_STMT (stmt))
9051 : {
9052 280 : stmt = build1_v (OMP_SECTION, stmt);
9053 280 : gfc_add_expr_to_block (&body, stmt);
9054 : }
9055 : }
9056 129 : stmt = gfc_finish_block (&body);
9057 :
9058 129 : stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses);
9059 129 : gfc_add_expr_to_block (&block, stmt);
9060 :
9061 129 : return gfc_finish_block (&block);
9062 : }
9063 :
9064 : static tree
9065 556 : gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
9066 : {
9067 556 : stmtblock_t block;
9068 556 : gfc_start_block (&block);
9069 556 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
9070 556 : tree stmt = gfc_trans_omp_code (code->block->next, true);
9071 556 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
9072 : stmt, omp_clauses);
9073 556 : gfc_add_expr_to_block (&block, stmt);
9074 556 : return gfc_finish_block (&block);
9075 : }
9076 :
9077 : static tree
9078 1093 : gfc_trans_omp_task (gfc_code *code)
9079 : {
9080 1093 : stmtblock_t block;
9081 1093 : tree stmt, omp_clauses;
9082 :
9083 1093 : gfc_start_block (&block);
9084 1093 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9085 : code->loc);
9086 1093 : pushlevel ();
9087 1093 : stmt = gfc_trans_omp_code (code->block->next, true);
9088 1093 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9089 1093 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node,
9090 : stmt, omp_clauses);
9091 1093 : gfc_add_expr_to_block (&block, stmt);
9092 1093 : return gfc_finish_block (&block);
9093 : }
9094 :
9095 : static tree
9096 181 : gfc_trans_omp_taskgroup (gfc_code *code)
9097 : {
9098 181 : stmtblock_t block;
9099 181 : gfc_start_block (&block);
9100 181 : tree body = gfc_trans_code (code->block->next);
9101 181 : tree stmt = make_node (OMP_TASKGROUP);
9102 181 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
9103 181 : TREE_TYPE (stmt) = void_type_node;
9104 181 : OMP_TASKGROUP_BODY (stmt) = body;
9105 181 : OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
9106 : code->ext.omp_clauses,
9107 : code->loc);
9108 181 : gfc_add_expr_to_block (&block, stmt);
9109 181 : return gfc_finish_block (&block);
9110 : }
9111 :
9112 : static tree
9113 146 : gfc_trans_omp_taskwait (gfc_code *code)
9114 : {
9115 146 : if (!code->ext.omp_clauses)
9116 : {
9117 132 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
9118 132 : return build_call_expr_loc (input_location, decl, 0);
9119 : }
9120 14 : stmtblock_t block;
9121 14 : gfc_start_block (&block);
9122 14 : tree stmt = make_node (OMP_TASK);
9123 14 : SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
9124 14 : TREE_TYPE (stmt) = void_type_node;
9125 14 : OMP_TASK_BODY (stmt) = NULL_TREE;
9126 14 : OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
9127 : code->ext.omp_clauses,
9128 : code->loc);
9129 14 : gfc_add_expr_to_block (&block, stmt);
9130 14 : return gfc_finish_block (&block);
9131 : }
9132 :
9133 : static tree
9134 8 : gfc_trans_omp_taskyield (void)
9135 : {
9136 8 : tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
9137 8 : return build_call_expr_loc (input_location, decl, 0);
9138 : }
9139 :
9140 : static tree
9141 341 : gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa)
9142 : {
9143 341 : stmtblock_t block;
9144 341 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
9145 341 : tree stmt, omp_clauses = NULL_TREE;
9146 341 : bool free_clausesa = false;
9147 :
9148 341 : gfc_start_block (&block);
9149 341 : if (clausesa == NULL)
9150 : {
9151 113 : clausesa = clausesa_buf;
9152 113 : gfc_split_omp_clauses (code, clausesa);
9153 113 : free_clausesa = true;
9154 : }
9155 341 : if (flag_openmp)
9156 341 : omp_clauses
9157 341 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
9158 : code->loc);
9159 341 : switch (code->op)
9160 : {
9161 0 : case EXEC_OMP_DISTRIBUTE:
9162 0 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9163 0 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9164 : /* This is handled in gfc_trans_omp_do. */
9165 0 : gcc_unreachable ();
9166 128 : break;
9167 128 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9168 128 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9169 128 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9170 128 : stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa);
9171 128 : if (TREE_CODE (stmt) != BIND_EXPR)
9172 128 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9173 : else
9174 0 : poplevel (0, 0);
9175 : break;
9176 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9177 113 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9178 113 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9179 113 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
9180 113 : if (TREE_CODE (stmt) != BIND_EXPR)
9181 113 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9182 : else
9183 0 : poplevel (0, 0);
9184 : break;
9185 100 : case EXEC_OMP_DISTRIBUTE_SIMD:
9186 100 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9187 100 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9188 100 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
9189 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
9190 100 : if (TREE_CODE (stmt) != BIND_EXPR)
9191 100 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9192 : else
9193 0 : poplevel (0, 0);
9194 : break;
9195 0 : default:
9196 0 : gcc_unreachable ();
9197 : }
9198 341 : if (flag_openmp)
9199 : {
9200 341 : tree distribute = make_node (OMP_DISTRIBUTE);
9201 341 : SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc));
9202 341 : TREE_TYPE (distribute) = void_type_node;
9203 341 : OMP_FOR_BODY (distribute) = stmt;
9204 341 : OMP_FOR_CLAUSES (distribute) = omp_clauses;
9205 341 : stmt = distribute;
9206 : }
9207 341 : gfc_add_expr_to_block (&block, stmt);
9208 341 : if (free_clausesa)
9209 113 : gfc_free_split_omp_clauses (code, clausesa);
9210 341 : return gfc_finish_block (&block);
9211 : }
9212 :
9213 : static tree
9214 460 : gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
9215 : tree omp_clauses)
9216 : {
9217 460 : stmtblock_t block;
9218 460 : gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
9219 460 : tree stmt;
9220 460 : bool combined = true, free_clausesa = false;
9221 :
9222 460 : gfc_start_block (&block);
9223 460 : if (clausesa == NULL)
9224 : {
9225 259 : clausesa = clausesa_buf;
9226 259 : gfc_split_omp_clauses (code, clausesa);
9227 259 : free_clausesa = true;
9228 : }
9229 460 : if (flag_openmp)
9230 : {
9231 460 : omp_clauses
9232 460 : = chainon (omp_clauses,
9233 : gfc_trans_omp_clauses (&block,
9234 : &clausesa[GFC_OMP_SPLIT_TEAMS],
9235 : code->loc));
9236 460 : pushlevel ();
9237 : }
9238 460 : switch (code->op)
9239 : {
9240 185 : case EXEC_OMP_TARGET_TEAMS:
9241 185 : case EXEC_OMP_TEAMS:
9242 185 : stmt = gfc_trans_omp_code (code->block->next, true);
9243 185 : combined = false;
9244 185 : break;
9245 28 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9246 28 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9247 28 : stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL,
9248 : &clausesa[GFC_OMP_SPLIT_DISTRIBUTE],
9249 : NULL);
9250 28 : break;
9251 19 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9252 19 : case EXEC_OMP_TEAMS_LOOP:
9253 19 : stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL,
9254 : &clausesa[GFC_OMP_SPLIT_DO],
9255 : NULL);
9256 19 : break;
9257 228 : default:
9258 228 : stmt = gfc_trans_omp_distribute (code, clausesa);
9259 228 : break;
9260 : }
9261 460 : if (flag_openmp)
9262 : {
9263 460 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9264 460 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS,
9265 : void_type_node, stmt, omp_clauses);
9266 460 : if (combined)
9267 275 : OMP_TEAMS_COMBINED (stmt) = 1;
9268 : }
9269 460 : gfc_add_expr_to_block (&block, stmt);
9270 460 : if (free_clausesa)
9271 259 : gfc_free_split_omp_clauses (code, clausesa);
9272 460 : return gfc_finish_block (&block);
9273 : }
9274 :
9275 : static tree
9276 2360 : gfc_trans_omp_target (gfc_code *code)
9277 : {
9278 2360 : stmtblock_t block;
9279 2360 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9280 2360 : tree stmt, omp_clauses = NULL_TREE;
9281 :
9282 2360 : gfc_start_block (&block);
9283 2360 : gfc_split_omp_clauses (code, clausesa);
9284 2360 : if (flag_openmp)
9285 2360 : omp_clauses
9286 2360 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
9287 : code->loc);
9288 2360 : switch (code->op)
9289 : {
9290 2015 : case EXEC_OMP_TARGET:
9291 2015 : pushlevel ();
9292 2015 : stmt = gfc_trans_omp_code (code->block->next, true);
9293 2015 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9294 2015 : break;
9295 23 : case EXEC_OMP_TARGET_PARALLEL:
9296 23 : {
9297 23 : stmtblock_t iblock;
9298 :
9299 23 : pushlevel ();
9300 23 : gfc_start_block (&iblock);
9301 23 : tree inner_clauses
9302 23 : = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
9303 : code->loc);
9304 23 : stmt = gfc_trans_omp_code (code->block->next, true);
9305 23 : stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
9306 : inner_clauses);
9307 23 : gfc_add_expr_to_block (&iblock, stmt);
9308 23 : stmt = gfc_finish_block (&iblock);
9309 23 : if (TREE_CODE (stmt) != BIND_EXPR)
9310 20 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9311 : else
9312 3 : poplevel (0, 0);
9313 : }
9314 23 : break;
9315 80 : case EXEC_OMP_TARGET_PARALLEL_DO:
9316 80 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9317 80 : stmt = gfc_trans_omp_parallel_do (code,
9318 : (code->op
9319 : == EXEC_OMP_TARGET_PARALLEL_LOOP),
9320 : &block, clausesa);
9321 80 : if (TREE_CODE (stmt) != BIND_EXPR)
9322 80 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9323 : else
9324 0 : poplevel (0, 0);
9325 : break;
9326 15 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9327 15 : stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa);
9328 15 : if (TREE_CODE (stmt) != BIND_EXPR)
9329 15 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9330 : else
9331 0 : poplevel (0, 0);
9332 : break;
9333 26 : case EXEC_OMP_TARGET_SIMD:
9334 26 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
9335 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
9336 26 : if (TREE_CODE (stmt) != BIND_EXPR)
9337 26 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9338 : else
9339 0 : poplevel (0, 0);
9340 : break;
9341 201 : default:
9342 201 : if (flag_openmp
9343 201 : && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
9344 149 : || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
9345 : {
9346 53 : gfc_omp_clauses clausesb;
9347 53 : tree teams_clauses;
9348 : /* For combined !$omp target teams, the num_teams and
9349 : thread_limit clauses are evaluated before entering the
9350 : target construct. */
9351 53 : memset (&clausesb, '\0', sizeof (clausesb));
9352 53 : clausesb.num_teams_lower
9353 53 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
9354 53 : clausesb.num_teams_upper
9355 53 : = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
9356 53 : clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
9357 53 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
9358 53 : clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
9359 53 : clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
9360 53 : teams_clauses
9361 53 : = gfc_trans_omp_clauses (&block, &clausesb, code->loc);
9362 53 : pushlevel ();
9363 53 : stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
9364 53 : }
9365 : else
9366 : {
9367 148 : pushlevel ();
9368 148 : stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
9369 : }
9370 201 : if (TREE_CODE (stmt) != BIND_EXPR)
9371 201 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9372 : else
9373 0 : poplevel (0, 0);
9374 : break;
9375 : }
9376 2360 : if (flag_openmp)
9377 : {
9378 2360 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET,
9379 : void_type_node, stmt, omp_clauses);
9380 2360 : if (code->op != EXEC_OMP_TARGET)
9381 345 : OMP_TARGET_COMBINED (stmt) = 1;
9382 2360 : cfun->has_omp_target = true;
9383 : }
9384 2360 : gfc_add_expr_to_block (&block, stmt);
9385 2360 : gfc_free_split_omp_clauses (code, clausesa);
9386 2360 : return gfc_finish_block (&block);
9387 : }
9388 :
9389 : static tree
9390 79 : gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
9391 : {
9392 79 : stmtblock_t block;
9393 79 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9394 79 : tree stmt, omp_clauses = NULL_TREE;
9395 :
9396 79 : gfc_start_block (&block);
9397 79 : gfc_split_omp_clauses (code, clausesa);
9398 79 : if (flag_openmp)
9399 79 : omp_clauses
9400 79 : = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
9401 : code->loc);
9402 79 : switch (op)
9403 : {
9404 0 : case EXEC_OMP_TASKLOOP:
9405 : /* This is handled in gfc_trans_omp_do. */
9406 0 : gcc_unreachable ();
9407 79 : break;
9408 79 : case EXEC_OMP_TASKLOOP_SIMD:
9409 79 : stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block,
9410 : &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE);
9411 79 : if (TREE_CODE (stmt) != BIND_EXPR)
9412 79 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9413 : else
9414 0 : poplevel (0, 0);
9415 79 : break;
9416 0 : default:
9417 0 : gcc_unreachable ();
9418 : }
9419 79 : if (flag_openmp)
9420 : {
9421 79 : tree taskloop = make_node (OMP_TASKLOOP);
9422 79 : SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc));
9423 79 : TREE_TYPE (taskloop) = void_type_node;
9424 79 : OMP_FOR_BODY (taskloop) = stmt;
9425 79 : OMP_FOR_CLAUSES (taskloop) = omp_clauses;
9426 79 : stmt = taskloop;
9427 : }
9428 79 : gfc_add_expr_to_block (&block, stmt);
9429 79 : gfc_free_split_omp_clauses (code, clausesa);
9430 79 : return gfc_finish_block (&block);
9431 : }
9432 :
9433 : static tree
9434 84 : gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
9435 : {
9436 84 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9437 84 : stmtblock_t block;
9438 84 : tree stmt;
9439 :
9440 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9441 56 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9442 45 : gfc_split_omp_clauses (code, clausesa);
9443 :
9444 84 : pushlevel ();
9445 84 : if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
9446 84 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
9447 48 : stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD);
9448 : else
9449 : {
9450 36 : gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
9451 : || op == EXEC_OMP_MASTER_TASKLOOP);
9452 36 : stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL,
9453 36 : code->op != EXEC_OMP_MASTER_TASKLOOP
9454 : ? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
9455 : : code->ext.omp_clauses, NULL);
9456 : }
9457 84 : if (TREE_CODE (stmt) != BIND_EXPR)
9458 55 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9459 : else
9460 29 : poplevel (0, 0);
9461 84 : gfc_start_block (&block);
9462 84 : if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
9463 : {
9464 35 : tree clauses = gfc_trans_omp_clauses (&block,
9465 : &clausesa[GFC_OMP_SPLIT_MASKED],
9466 : code->loc);
9467 35 : tree msk = make_node (OMP_MASKED);
9468 35 : SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc));
9469 35 : TREE_TYPE (msk) = void_type_node;
9470 35 : OMP_MASKED_BODY (msk) = stmt;
9471 35 : OMP_MASKED_CLAUSES (msk) = clauses;
9472 35 : OMP_MASKED_COMBINED (msk) = 1;
9473 35 : gfc_add_expr_to_block (&block, msk);
9474 : }
9475 : else
9476 : {
9477 49 : gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
9478 : || op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
9479 49 : stmt = build1_v (OMP_MASTER, stmt);
9480 49 : gfc_add_expr_to_block (&block, stmt);
9481 : }
9482 84 : if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
9483 56 : && code->op != EXEC_OMP_MASTER_TASKLOOP)
9484 45 : gfc_free_split_omp_clauses (code, clausesa);
9485 84 : return gfc_finish_block (&block);
9486 : }
9487 :
9488 : static tree
9489 61 : gfc_trans_omp_parallel_master_masked (gfc_code *code)
9490 : {
9491 61 : stmtblock_t block;
9492 61 : tree stmt, omp_clauses;
9493 61 : gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
9494 61 : bool parallel_combined = false;
9495 :
9496 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9497 50 : gfc_split_omp_clauses (code, clausesa);
9498 :
9499 61 : gfc_start_block (&block);
9500 61 : omp_clauses = gfc_trans_omp_clauses (&block,
9501 61 : code->op == EXEC_OMP_PARALLEL_MASTER
9502 : ? code->ext.omp_clauses
9503 : : &clausesa[GFC_OMP_SPLIT_PARALLEL],
9504 : code->loc);
9505 61 : pushlevel ();
9506 61 : if (code->op == EXEC_OMP_PARALLEL_MASTER)
9507 11 : stmt = gfc_trans_omp_master (code);
9508 50 : else if (code->op == EXEC_OMP_PARALLEL_MASKED)
9509 11 : stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]);
9510 : else
9511 : {
9512 39 : gfc_exec_op op;
9513 39 : switch (code->op)
9514 : {
9515 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9516 : op = EXEC_OMP_MASKED_TASKLOOP;
9517 : break;
9518 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9519 8 : op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
9520 8 : break;
9521 10 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9522 10 : op = EXEC_OMP_MASTER_TASKLOOP;
9523 10 : break;
9524 14 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9525 14 : op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
9526 14 : break;
9527 0 : default:
9528 0 : gcc_unreachable ();
9529 : }
9530 39 : stmt = gfc_trans_omp_master_masked_taskloop (code, op);
9531 39 : parallel_combined = true;
9532 : }
9533 61 : if (TREE_CODE (stmt) != BIND_EXPR)
9534 48 : stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
9535 : else
9536 13 : poplevel (0, 0);
9537 61 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
9538 : void_type_node, stmt, omp_clauses);
9539 : /* masked does have just filter clause, but during gimplification
9540 : isn't represented by a gimplification omp context, so for
9541 : !$omp parallel masked don't set OMP_PARALLEL_COMBINED,
9542 : so that
9543 : !$omp parallel masked
9544 : !$omp taskloop simd lastprivate (x)
9545 : isn't confused with
9546 : !$omp parallel masked taskloop simd lastprivate (x) */
9547 61 : if (parallel_combined)
9548 39 : OMP_PARALLEL_COMBINED (stmt) = 1;
9549 61 : gfc_add_expr_to_block (&block, stmt);
9550 61 : if (code->op != EXEC_OMP_PARALLEL_MASTER)
9551 50 : gfc_free_split_omp_clauses (code, clausesa);
9552 61 : return gfc_finish_block (&block);
9553 : }
9554 :
9555 : static tree
9556 1389 : gfc_trans_omp_target_data (gfc_code *code)
9557 : {
9558 1389 : stmtblock_t block;
9559 1389 : tree stmt, omp_clauses;
9560 :
9561 1389 : gfc_start_block (&block);
9562 1389 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9563 : code->loc);
9564 1389 : stmt = gfc_trans_omp_code (code->block->next, true);
9565 1389 : stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA,
9566 : void_type_node, stmt, omp_clauses);
9567 1389 : gfc_add_expr_to_block (&block, stmt);
9568 1389 : return gfc_finish_block (&block);
9569 : }
9570 :
9571 : static tree
9572 437 : gfc_trans_omp_target_enter_data (gfc_code *code)
9573 : {
9574 437 : stmtblock_t block;
9575 437 : tree stmt, omp_clauses;
9576 :
9577 437 : gfc_start_block (&block);
9578 437 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9579 : code->loc);
9580 437 : stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
9581 : omp_clauses);
9582 437 : gfc_add_expr_to_block (&block, stmt);
9583 437 : return gfc_finish_block (&block);
9584 : }
9585 :
9586 : static tree
9587 361 : gfc_trans_omp_target_exit_data (gfc_code *code)
9588 : {
9589 361 : stmtblock_t block;
9590 361 : tree stmt, omp_clauses;
9591 :
9592 361 : gfc_start_block (&block);
9593 361 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9594 : code->loc, false, false, code->op);
9595 361 : stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
9596 : omp_clauses);
9597 361 : gfc_add_expr_to_block (&block, stmt);
9598 361 : return gfc_finish_block (&block);
9599 : }
9600 :
9601 : static tree
9602 1708 : gfc_trans_omp_target_update (gfc_code *code)
9603 : {
9604 1708 : stmtblock_t block;
9605 1708 : tree stmt, omp_clauses;
9606 :
9607 1708 : gfc_start_block (&block);
9608 1708 : omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
9609 : code->loc);
9610 1708 : stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node,
9611 : omp_clauses);
9612 1708 : gfc_add_expr_to_block (&block, stmt);
9613 1708 : return gfc_finish_block (&block);
9614 : }
9615 :
9616 : static tree
9617 8 : gfc_trans_openmp_interop (gfc_code *code, gfc_omp_clauses *clauses)
9618 : {
9619 8 : stmtblock_t block;
9620 8 : gfc_start_block (&block);
9621 8 : tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
9622 8 : tree stmt = build1_loc (input_location, OMP_INTEROP, void_type_node,
9623 : omp_clauses);
9624 8 : gfc_add_expr_to_block (&block, stmt);
9625 8 : return gfc_finish_block (&block);
9626 : }
9627 :
9628 : static tree
9629 85 : gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
9630 : {
9631 85 : tree res, tmp, stmt;
9632 85 : stmtblock_t block, *pblock = NULL;
9633 85 : stmtblock_t singleblock;
9634 85 : int saved_ompws_flags;
9635 85 : bool singleblock_in_progress = false;
9636 : /* True if previous gfc_code in workshare construct is not workshared. */
9637 85 : bool prev_singleunit;
9638 85 : location_t loc = gfc_get_location (&code->loc);
9639 :
9640 85 : code = code->block->next;
9641 :
9642 85 : pushlevel ();
9643 :
9644 85 : gfc_start_block (&block);
9645 85 : pblock = █
9646 :
9647 85 : ompws_flags = OMPWS_WORKSHARE_FLAG;
9648 85 : prev_singleunit = false;
9649 :
9650 : /* Translate statements one by one to trees until we reach
9651 : the end of the workshare construct. Adjacent gfc_codes that
9652 : are a single unit of work are clustered and encapsulated in a
9653 : single OMP_SINGLE construct. */
9654 282 : for (; code; code = code->next)
9655 : {
9656 197 : if (code->here != 0)
9657 : {
9658 0 : res = gfc_trans_label_here (code);
9659 0 : gfc_add_expr_to_block (pblock, res);
9660 : }
9661 :
9662 : /* No dependence analysis, use for clauses with wait.
9663 : If this is the last gfc_code, use default omp_clauses. */
9664 197 : if (code->next == NULL && clauses->nowait)
9665 60 : ompws_flags |= OMPWS_NOWAIT;
9666 :
9667 : /* By default, every gfc_code is a single unit of work. */
9668 197 : ompws_flags |= OMPWS_CURR_SINGLEUNIT;
9669 197 : ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
9670 :
9671 197 : switch (code->op)
9672 : {
9673 : case EXEC_NOP:
9674 : res = NULL_TREE;
9675 : break;
9676 :
9677 125 : case EXEC_ASSIGN:
9678 125 : res = gfc_trans_assign (code);
9679 125 : break;
9680 :
9681 0 : case EXEC_POINTER_ASSIGN:
9682 0 : res = gfc_trans_pointer_assign (code);
9683 0 : break;
9684 :
9685 0 : case EXEC_INIT_ASSIGN:
9686 0 : res = gfc_trans_init_assign (code);
9687 0 : break;
9688 :
9689 24 : case EXEC_FORALL:
9690 24 : res = gfc_trans_forall (code);
9691 24 : break;
9692 :
9693 19 : case EXEC_WHERE:
9694 19 : res = gfc_trans_where (code);
9695 19 : break;
9696 :
9697 7 : case EXEC_OMP_ATOMIC:
9698 7 : res = gfc_trans_omp_directive (code);
9699 7 : break;
9700 :
9701 17 : case EXEC_OMP_PARALLEL:
9702 17 : case EXEC_OMP_PARALLEL_DO:
9703 17 : case EXEC_OMP_PARALLEL_MASTER:
9704 17 : case EXEC_OMP_PARALLEL_SECTIONS:
9705 17 : case EXEC_OMP_PARALLEL_WORKSHARE:
9706 17 : case EXEC_OMP_CRITICAL:
9707 17 : saved_ompws_flags = ompws_flags;
9708 17 : ompws_flags = 0;
9709 17 : res = gfc_trans_omp_directive (code);
9710 17 : ompws_flags = saved_ompws_flags;
9711 17 : break;
9712 :
9713 5 : case EXEC_BLOCK:
9714 5 : res = gfc_trans_block_construct (code);
9715 5 : break;
9716 :
9717 0 : default:
9718 0 : gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
9719 : }
9720 :
9721 197 : input_location = gfc_get_location (&code->loc);
9722 :
9723 197 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
9724 : {
9725 197 : if (prev_singleunit)
9726 : {
9727 72 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9728 : /* Add current gfc_code to single block. */
9729 44 : gfc_add_expr_to_block (&singleblock, res);
9730 : else
9731 : {
9732 : /* Finish single block and add it to pblock. */
9733 28 : tmp = gfc_finish_block (&singleblock);
9734 28 : tmp = build2_loc (loc, OMP_SINGLE,
9735 : void_type_node, tmp, NULL_TREE);
9736 28 : gfc_add_expr_to_block (pblock, tmp);
9737 : /* Add current gfc_code to pblock. */
9738 28 : gfc_add_expr_to_block (pblock, res);
9739 28 : singleblock_in_progress = false;
9740 : }
9741 : }
9742 : else
9743 : {
9744 125 : if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
9745 : {
9746 : /* Start single block. */
9747 73 : gfc_init_block (&singleblock);
9748 73 : gfc_add_expr_to_block (&singleblock, res);
9749 73 : singleblock_in_progress = true;
9750 73 : loc = gfc_get_location (&code->loc);
9751 : }
9752 : else
9753 : /* Add the new statement to the block. */
9754 52 : gfc_add_expr_to_block (pblock, res);
9755 : }
9756 197 : prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
9757 : }
9758 : }
9759 :
9760 : /* Finish remaining SINGLE block, if we were in the middle of one. */
9761 85 : if (singleblock_in_progress)
9762 : {
9763 : /* Finish single block and add it to pblock. */
9764 45 : tmp = gfc_finish_block (&singleblock);
9765 45 : tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp,
9766 45 : clauses->nowait
9767 27 : ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
9768 : : NULL_TREE);
9769 45 : gfc_add_expr_to_block (pblock, tmp);
9770 : }
9771 :
9772 85 : stmt = gfc_finish_block (pblock);
9773 85 : if (TREE_CODE (stmt) != BIND_EXPR)
9774 : {
9775 65 : if (!IS_EMPTY_STMT (stmt))
9776 : {
9777 65 : tree bindblock = poplevel (1, 0);
9778 65 : stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
9779 : }
9780 : else
9781 0 : poplevel (0, 0);
9782 : }
9783 : else
9784 20 : poplevel (0, 0);
9785 :
9786 85 : if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
9787 0 : stmt = gfc_trans_omp_barrier ();
9788 :
9789 85 : ompws_flags = 0;
9790 85 : return stmt;
9791 : }
9792 :
9793 : tree
9794 76 : gfc_trans_oacc_declare (gfc_code *code)
9795 : {
9796 76 : stmtblock_t block;
9797 76 : tree stmt, oacc_clauses;
9798 76 : enum tree_code construct_code;
9799 :
9800 76 : construct_code = OACC_DATA;
9801 :
9802 76 : gfc_start_block (&block);
9803 :
9804 76 : oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
9805 : code->loc, false, true);
9806 76 : stmt = gfc_trans_omp_code (code->block->next, true);
9807 76 : stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
9808 : oacc_clauses);
9809 76 : gfc_add_expr_to_block (&block, stmt);
9810 :
9811 76 : return gfc_finish_block (&block);
9812 : }
9813 :
9814 : tree
9815 12044 : gfc_trans_oacc_directive (gfc_code *code)
9816 : {
9817 12044 : switch (code->op)
9818 : {
9819 1556 : case EXEC_OACC_PARALLEL_LOOP:
9820 1556 : case EXEC_OACC_KERNELS_LOOP:
9821 1556 : case EXEC_OACC_SERIAL_LOOP:
9822 1556 : return gfc_trans_oacc_combined_directive (code);
9823 4189 : case EXEC_OACC_PARALLEL:
9824 4189 : case EXEC_OACC_KERNELS:
9825 4189 : case EXEC_OACC_SERIAL:
9826 4189 : case EXEC_OACC_DATA:
9827 4189 : case EXEC_OACC_HOST_DATA:
9828 4189 : return gfc_trans_oacc_construct (code);
9829 3377 : case EXEC_OACC_LOOP:
9830 3377 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9831 3377 : NULL);
9832 2130 : case EXEC_OACC_UPDATE:
9833 2130 : case EXEC_OACC_CACHE:
9834 2130 : case EXEC_OACC_ENTER_DATA:
9835 2130 : case EXEC_OACC_EXIT_DATA:
9836 2130 : return gfc_trans_oacc_executable_directive (code);
9837 173 : case EXEC_OACC_WAIT:
9838 173 : return gfc_trans_oacc_wait_directive (code);
9839 543 : case EXEC_OACC_ATOMIC:
9840 543 : return gfc_trans_omp_atomic (code);
9841 76 : case EXEC_OACC_DECLARE:
9842 76 : return gfc_trans_oacc_declare (code);
9843 0 : default:
9844 0 : gcc_unreachable ();
9845 : }
9846 : }
9847 :
9848 : tree
9849 19036 : gfc_trans_omp_directive (gfc_code *code)
9850 : {
9851 19036 : switch (code->op)
9852 : {
9853 35 : case EXEC_OMP_ALLOCATE:
9854 35 : case EXEC_OMP_ALLOCATORS:
9855 35 : return gfc_trans_omp_allocators (code);
9856 10 : case EXEC_OMP_ASSUME:
9857 10 : return gfc_trans_omp_assume (code);
9858 2009 : case EXEC_OMP_ATOMIC:
9859 2009 : return gfc_trans_omp_atomic (code);
9860 580 : case EXEC_OMP_BARRIER:
9861 580 : return gfc_trans_omp_barrier ();
9862 232 : case EXEC_OMP_CANCEL:
9863 232 : return gfc_trans_omp_cancel (code);
9864 170 : case EXEC_OMP_CANCELLATION_POINT:
9865 170 : return gfc_trans_omp_cancellation_point (code);
9866 143 : case EXEC_OMP_CRITICAL:
9867 143 : return gfc_trans_omp_critical (code);
9868 108 : case EXEC_OMP_DEPOBJ:
9869 108 : return gfc_trans_omp_depobj (code);
9870 2370 : case EXEC_OMP_DISTRIBUTE:
9871 2370 : case EXEC_OMP_DO:
9872 2370 : case EXEC_OMP_LOOP:
9873 2370 : case EXEC_OMP_SIMD:
9874 2370 : case EXEC_OMP_TASKLOOP:
9875 2370 : case EXEC_OMP_TILE:
9876 2370 : case EXEC_OMP_UNROLL:
9877 2370 : return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
9878 2370 : NULL);
9879 128 : case EXEC_OMP_DISPATCH:
9880 128 : return gfc_trans_omp_dispatch (code);
9881 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9882 113 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9883 113 : case EXEC_OMP_DISTRIBUTE_SIMD:
9884 113 : return gfc_trans_omp_distribute (code, NULL);
9885 126 : case EXEC_OMP_DO_SIMD:
9886 126 : return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
9887 29 : case EXEC_OMP_ERROR:
9888 29 : return gfc_trans_omp_error (code);
9889 70 : case EXEC_OMP_FLUSH:
9890 70 : return gfc_trans_omp_flush (code);
9891 44 : case EXEC_OMP_MASKED:
9892 44 : return gfc_trans_omp_masked (code, NULL);
9893 105 : case EXEC_OMP_MASTER:
9894 105 : return gfc_trans_omp_master (code);
9895 45 : case EXEC_OMP_MASKED_TASKLOOP:
9896 45 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9897 45 : case EXEC_OMP_MASTER_TASKLOOP:
9898 45 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9899 45 : return gfc_trans_omp_master_masked_taskloop (code, code->op);
9900 88 : case EXEC_OMP_METADIRECTIVE:
9901 88 : return gfc_trans_omp_metadirective (code);
9902 521 : case EXEC_OMP_ORDERED:
9903 521 : return gfc_trans_omp_ordered (code);
9904 1854 : case EXEC_OMP_PARALLEL:
9905 1854 : return gfc_trans_omp_parallel (code);
9906 1082 : case EXEC_OMP_PARALLEL_DO:
9907 1082 : return gfc_trans_omp_parallel_do (code, false, NULL, NULL);
9908 24 : case EXEC_OMP_PARALLEL_LOOP:
9909 24 : return gfc_trans_omp_parallel_do (code, true, NULL, NULL);
9910 285 : case EXEC_OMP_PARALLEL_DO_SIMD:
9911 285 : return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
9912 61 : case EXEC_OMP_PARALLEL_MASKED:
9913 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9914 61 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9915 61 : case EXEC_OMP_PARALLEL_MASTER:
9916 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9917 61 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9918 61 : return gfc_trans_omp_parallel_master_masked (code);
9919 54 : case EXEC_OMP_PARALLEL_SECTIONS:
9920 54 : return gfc_trans_omp_parallel_sections (code);
9921 50 : case EXEC_OMP_PARALLEL_WORKSHARE:
9922 50 : return gfc_trans_omp_parallel_workshare (code);
9923 53 : case EXEC_OMP_SCOPE:
9924 53 : return gfc_trans_omp_scope (code);
9925 75 : case EXEC_OMP_SECTIONS:
9926 75 : return gfc_trans_omp_sections (code, code->ext.omp_clauses);
9927 556 : case EXEC_OMP_SINGLE:
9928 556 : return gfc_trans_omp_single (code, code->ext.omp_clauses);
9929 2360 : case EXEC_OMP_TARGET:
9930 2360 : case EXEC_OMP_TARGET_PARALLEL:
9931 2360 : case EXEC_OMP_TARGET_PARALLEL_DO:
9932 2360 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9933 2360 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9934 2360 : case EXEC_OMP_TARGET_SIMD:
9935 2360 : case EXEC_OMP_TARGET_TEAMS:
9936 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9937 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9938 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9939 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9940 2360 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9941 2360 : return gfc_trans_omp_target (code);
9942 1389 : case EXEC_OMP_TARGET_DATA:
9943 1389 : return gfc_trans_omp_target_data (code);
9944 437 : case EXEC_OMP_TARGET_ENTER_DATA:
9945 437 : return gfc_trans_omp_target_enter_data (code);
9946 361 : case EXEC_OMP_TARGET_EXIT_DATA:
9947 361 : return gfc_trans_omp_target_exit_data (code);
9948 1708 : case EXEC_OMP_TARGET_UPDATE:
9949 1708 : return gfc_trans_omp_target_update (code);
9950 1093 : case EXEC_OMP_TASK:
9951 1093 : return gfc_trans_omp_task (code);
9952 181 : case EXEC_OMP_TASKGROUP:
9953 181 : return gfc_trans_omp_taskgroup (code);
9954 31 : case EXEC_OMP_TASKLOOP_SIMD:
9955 31 : return gfc_trans_omp_taskloop (code, code->op);
9956 146 : case EXEC_OMP_TASKWAIT:
9957 146 : return gfc_trans_omp_taskwait (code);
9958 8 : case EXEC_OMP_TASKYIELD:
9959 8 : return gfc_trans_omp_taskyield ();
9960 259 : case EXEC_OMP_TEAMS:
9961 259 : case EXEC_OMP_TEAMS_DISTRIBUTE:
9962 259 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9963 259 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9964 259 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9965 259 : case EXEC_OMP_TEAMS_LOOP:
9966 259 : return gfc_trans_omp_teams (code, NULL, NULL_TREE);
9967 35 : case EXEC_OMP_WORKSHARE:
9968 35 : return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
9969 8 : case EXEC_OMP_INTEROP:
9970 8 : return gfc_trans_openmp_interop (code, code->ext.omp_clauses);
9971 0 : default:
9972 0 : gcc_unreachable ();
9973 : }
9974 : }
9975 :
9976 : void
9977 109 : gfc_trans_omp_declare_simd (gfc_namespace *ns)
9978 : {
9979 109 : if (ns->entries)
9980 : return;
9981 :
9982 109 : gfc_omp_declare_simd *ods;
9983 262 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
9984 : {
9985 153 : tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
9986 153 : tree fndecl = ns->proc_name->backend_decl;
9987 153 : if (c != NULL_TREE)
9988 103 : c = tree_cons (NULL_TREE, c, NULL_TREE);
9989 153 : c = build_tree_list (get_identifier ("omp declare simd"), c);
9990 153 : TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
9991 153 : DECL_ATTRIBUTES (fndecl) = c;
9992 : }
9993 : }
9994 :
9995 : /* Translate the context selector list GFC_SELECTORS, using WHERE as the
9996 : locus for error messages. */
9997 :
9998 : static tree
9999 513 : gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where)
10000 : {
10001 513 : tree set_selectors = NULL_TREE;
10002 513 : gfc_omp_set_selector *oss;
10003 :
10004 1004 : for (oss = gfc_selectors; oss; oss = oss->next)
10005 : {
10006 491 : tree selectors = NULL_TREE;
10007 491 : gfc_omp_selector *os;
10008 491 : enum omp_tss_code set = oss->code;
10009 491 : gcc_assert (set != OMP_TRAIT_SET_INVALID);
10010 :
10011 1107 : for (os = oss->trait_selectors; os; os = os->next)
10012 : {
10013 616 : tree scoreval = NULL_TREE;
10014 616 : tree properties = NULL_TREE;
10015 616 : gfc_omp_trait_property *otp;
10016 616 : enum omp_ts_code sel = os->code;
10017 :
10018 : /* Per the spec, "Implementations can ignore specified
10019 : selectors that are not those described in this section";
10020 : however, we must record such selectors because they
10021 : cause match failures. */
10022 616 : if (sel == OMP_TRAIT_INVALID)
10023 : {
10024 1 : selectors = make_trait_selector (sel, NULL_TREE, NULL_TREE,
10025 : selectors);
10026 1 : continue;
10027 : }
10028 :
10029 987 : for (otp = os->properties; otp; otp = otp->next)
10030 : {
10031 372 : switch (otp->property_kind)
10032 : {
10033 85 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
10034 85 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
10035 85 : {
10036 85 : tree expr = NULL_TREE;
10037 85 : gfc_se se;
10038 85 : gfc_init_se (&se, NULL);
10039 85 : gfc_conv_expr (&se, otp->expr);
10040 85 : expr = se.expr;
10041 85 : properties = make_trait_property (NULL_TREE, expr,
10042 : properties);
10043 : }
10044 85 : break;
10045 23 : case OMP_TRAIT_PROPERTY_ID:
10046 23 : properties
10047 23 : = make_trait_property (get_identifier (otp->name),
10048 : NULL_TREE, properties);
10049 23 : break;
10050 250 : case OMP_TRAIT_PROPERTY_NAME_LIST:
10051 250 : {
10052 250 : tree prop = OMP_TP_NAMELIST_NODE;
10053 250 : tree value = NULL_TREE;
10054 250 : if (otp->is_name)
10055 165 : value = get_identifier (otp->name);
10056 : else
10057 85 : value = gfc_conv_constant_to_tree (otp->expr);
10058 :
10059 250 : properties = make_trait_property (prop, value,
10060 : properties);
10061 : }
10062 250 : break;
10063 14 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
10064 14 : properties = gfc_trans_omp_clauses (NULL, otp->clauses,
10065 : where, true);
10066 14 : break;
10067 0 : default:
10068 0 : gcc_unreachable ();
10069 : }
10070 : }
10071 :
10072 615 : if (os->score)
10073 : {
10074 51 : gfc_se se;
10075 51 : gfc_init_se (&se, NULL);
10076 51 : gfc_conv_expr (&se, os->score);
10077 51 : scoreval = se.expr;
10078 : }
10079 :
10080 615 : selectors = make_trait_selector (sel, scoreval,
10081 : properties, selectors);
10082 : }
10083 491 : set_selectors = make_trait_set_selector (set, selectors, set_selectors);
10084 : }
10085 513 : return set_selectors;
10086 : }
10087 :
10088 : /* If 'ns' points to a formal namespace in an interface, ns->parent == NULL;
10089 : hence, parent_ns is used instead. */
10090 :
10091 : void
10092 10566 : gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns)
10093 : {
10094 10566 : tree base_fn_decl = ns->proc_name->backend_decl;
10095 10566 : gfc_namespace *search_ns = ns;
10096 10566 : gfc_omp_declare_variant *next;
10097 :
10098 10566 : for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
10099 28652 : search_ns; odv = next)
10100 : {
10101 : /* Look in the parent namespace if there are no more directives in the
10102 : current namespace. */
10103 18086 : if (!odv)
10104 : {
10105 17701 : if (!search_ns->parent && search_ns == ns)
10106 : search_ns = parent_ns;
10107 : else
10108 12438 : search_ns = search_ns->parent;
10109 17701 : if (search_ns)
10110 7135 : next = search_ns->omp_declare_variant;
10111 17701 : continue;
10112 : }
10113 :
10114 385 : next = odv->next;
10115 :
10116 385 : if (odv->error_p)
10117 17 : continue;
10118 :
10119 : /* Check directive the first time it is encountered. */
10120 368 : bool error_found = true;
10121 :
10122 368 : if (odv->checked_p)
10123 43 : error_found = false;
10124 368 : if (odv->base_proc_symtree == NULL)
10125 : {
10126 331 : if (!search_ns->proc_name->attr.function
10127 212 : && !search_ns->proc_name->attr.subroutine)
10128 1 : gfc_error ("The base name for %<declare variant%> must be "
10129 : "specified at %L", &odv->where);
10130 : else
10131 : error_found = false;
10132 : }
10133 : else
10134 : {
10135 37 : if (!search_ns->contained
10136 21 : && !odv->base_proc_symtree->n.sym->attr.use_assoc
10137 5 : && strcmp (odv->base_proc_symtree->name,
10138 5 : ns->proc_name->name))
10139 1 : gfc_error ("The base name at %L does not match the name of the "
10140 : "current procedure", &odv->where);
10141 36 : else if (odv->base_proc_symtree->n.sym->attr.entry)
10142 1 : gfc_error ("The base name at %L must not be an entry name",
10143 : &odv->where);
10144 35 : else if (odv->base_proc_symtree->n.sym->attr.generic)
10145 1 : gfc_error ("The base name at %L must not be a generic name",
10146 : &odv->where);
10147 34 : else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
10148 1 : gfc_error ("The base name at %L must not be a procedure pointer",
10149 : &odv->where);
10150 33 : else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
10151 1 : gfc_error ("The base procedure at %L must have an explicit "
10152 : "interface", &odv->where);
10153 : else
10154 : error_found = false;
10155 : }
10156 :
10157 368 : odv->checked_p = true;
10158 368 : if (error_found)
10159 : {
10160 6 : odv->error_p = true;
10161 6 : continue;
10162 : }
10163 :
10164 : /* Ignore directives that do not apply to the current procedure. */
10165 362 : if ((odv->base_proc_symtree == NULL && search_ns != ns)
10166 336 : || (odv->base_proc_symtree != NULL
10167 32 : && !ns->proc_name->attr.use_assoc
10168 19 : && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))
10169 323 : || (odv->base_proc_symtree != NULL
10170 19 : && ns->proc_name->attr.use_assoc
10171 13 : && strcmp (odv->base_proc_symtree->n.sym->name,
10172 : ns->proc_name->name)))
10173 44 : continue;
10174 :
10175 318 : tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors,
10176 : odv->where);
10177 318 : const char *variant_proc_name = odv->variant_proc_symtree->name;
10178 318 : gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
10179 318 : if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
10180 : {
10181 39 : gfc_symtree *proc_st;
10182 39 : gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
10183 39 : variant_proc_sym = proc_st ? proc_st->n.sym : NULL;
10184 : }
10185 39 : if (variant_proc_sym == NULL)
10186 : {
10187 1 : gfc_error ("Cannot find symbol %qs at %L", variant_proc_name,
10188 : &odv->where);
10189 1 : continue;
10190 : }
10191 317 : set_selectors = omp_check_context_selector
10192 317 : (gfc_get_location (&odv->where), set_selectors,
10193 : OMP_CTX_DECLARE_VARIANT);
10194 317 : if (set_selectors != error_mark_node)
10195 : {
10196 297 : if (!variant_proc_sym->attr.implicit_type
10197 297 : && !variant_proc_sym->attr.subroutine
10198 89 : && !variant_proc_sym->attr.function)
10199 : {
10200 0 : gfc_error ("variant %qs at %L is not a function or subroutine",
10201 : variant_proc_name, &odv->where);
10202 0 : variant_proc_sym = NULL;
10203 : }
10204 297 : else if (variant_proc_sym == ns->proc_name)
10205 : {
10206 1 : gfc_error ("variant %qs at %L is the same as base function",
10207 : variant_proc_name, &odv->where);
10208 1 : variant_proc_sym = NULL;
10209 : }
10210 296 : else if (omp_get_context_selector (set_selectors,
10211 : OMP_TRAIT_SET_CONSTRUCT,
10212 : OMP_TRAIT_CONSTRUCT_SIMD)
10213 : == NULL_TREE)
10214 : {
10215 282 : char err[256];
10216 282 : gfc_formal_arglist *last_arg = NULL, *extra_arg = NULL;
10217 282 : int nappend_args = 0;
10218 282 : if (odv->append_args_list)
10219 : {
10220 26 : gfc_formal_arglist *arg;
10221 26 : int nargs = 0;
10222 26 : for (arg = gfc_sym_get_dummy_args (ns->proc_name);
10223 56 : arg; arg = arg->next)
10224 30 : nargs++;
10225 :
10226 26 : last_arg = gfc_sym_get_dummy_args (variant_proc_sym);
10227 33 : for (int i = 1 ; i < nargs && last_arg; i++)
10228 7 : last_arg = last_arg->next;
10229 26 : if (nargs == 0)
10230 : {
10231 3 : extra_arg = last_arg;
10232 3 : last_arg = NULL;
10233 3 : variant_proc_sym->formal = NULL;
10234 : }
10235 23 : else if (last_arg)
10236 : {
10237 23 : extra_arg = last_arg->next;
10238 23 : last_arg->next = NULL;
10239 : }
10240 76 : for (gfc_omp_namelist *n = odv->append_args_list; n != NULL;
10241 50 : n = n->next)
10242 50 : nappend_args++;
10243 : }
10244 282 : if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
10245 : variant_proc_sym->name, 0, 1,
10246 : err, sizeof (err), NULL, NULL))
10247 : {
10248 2 : gfc_error ("variant %qs and base %qs at %L have "
10249 : "incompatible types: %s",
10250 2 : variant_proc_name, ns->proc_name->name,
10251 : &odv->where, err);
10252 2 : if (nappend_args)
10253 0 : inform (gfc_get_location (&odv->append_args_list->where),
10254 : "%<append_args%> clause implies that %qs has %d "
10255 : "dummy arguments of integer type with "
10256 : "%<omp_interop_kind%> kind", variant_proc_name,
10257 : nappend_args);
10258 : variant_proc_sym = NULL;
10259 : }
10260 282 : if (last_arg)
10261 23 : last_arg->next = extra_arg;
10262 259 : else if (extra_arg)
10263 3 : variant_proc_sym->formal = extra_arg;
10264 26 : locus *loc = (odv->append_args_list
10265 282 : ? &odv->append_args_list->where : &odv->where);
10266 282 : int nextra_arg = 0;
10267 335 : for (; extra_arg; extra_arg = extra_arg->next)
10268 : {
10269 53 : nextra_arg++;
10270 53 : if (!variant_proc_sym)
10271 8 : continue;
10272 45 : if (extra_arg->sym->ts.type != BT_INTEGER
10273 43 : || extra_arg->sym->ts.kind != gfc_index_integer_kind
10274 42 : || extra_arg->sym->attr.dimension
10275 40 : || extra_arg->sym->attr.codimension
10276 39 : || extra_arg->sym->attr.pointer
10277 38 : || extra_arg->sym->attr.allocatable
10278 37 : || extra_arg->sym->attr.proc_pointer)
10279 : {
10280 8 : gfc_error ("%qs at %L must be a nonpointer, "
10281 : "nonallocatable scalar integer dummy argument "
10282 : "of %<omp_interop_kind%> kind as it utilized "
10283 : "with the %<append_args%> clause at %L",
10284 : extra_arg->sym->name,
10285 : &extra_arg->sym->declared_at, loc);
10286 8 : variant_proc_sym = NULL;
10287 : }
10288 45 : if (extra_arg->sym->attr.optional)
10289 : {
10290 2 : gfc_error ("%qs at %L with OPTIONAL attribute "
10291 : "not support when utilized with the "
10292 : "%<append_args%> clause at %L",
10293 : extra_arg->sym->name,
10294 : &extra_arg->sym->declared_at, loc);
10295 2 : variant_proc_sym = NULL;
10296 : }
10297 : }
10298 282 : if (variant_proc_sym && nappend_args != nextra_arg)
10299 : {
10300 1 : gfc_error ("%qs at %L has %d but requires %d "
10301 : "%<omp_interop_kind%> kind dummy arguments as it "
10302 : "is utilized with the %<append_args%> clause at "
10303 : "%L", variant_proc_sym->name,
10304 : &variant_proc_sym->declared_at, nextra_arg,
10305 : nappend_args, loc);
10306 1 : variant_proc_sym = NULL;
10307 : }
10308 : }
10309 251 : if ((odv->adjust_args_list != NULL || odv->append_args_list != NULL)
10310 322 : && omp_get_context_selector (set_selectors,
10311 : OMP_TRAIT_SET_CONSTRUCT,
10312 : OMP_TRAIT_CONSTRUCT_DISPATCH)
10313 : == NULL_TREE)
10314 : {
10315 6 : gfc_error ("the %qs clause can only be specified if "
10316 : "the %<dispatch%> selector of the construct "
10317 : "selector set appears in the %<match%> clause at %L",
10318 3 : odv->adjust_args_list ? "adjust_args" : "append_args",
10319 : &odv->where);
10320 3 : variant_proc_sym = NULL;
10321 : }
10322 297 : if (variant_proc_sym != NULL)
10323 : {
10324 281 : gfc_set_sym_referenced (variant_proc_sym);
10325 281 : tree construct
10326 281 : = omp_get_context_selector_list (set_selectors,
10327 : OMP_TRAIT_SET_CONSTRUCT);
10328 281 : omp_mark_declare_variant (gfc_get_location (&odv->where),
10329 : gfc_get_symbol_decl (variant_proc_sym),
10330 : construct);
10331 281 : if (omp_context_selector_matches (set_selectors,
10332 : NULL_TREE, false))
10333 : {
10334 202 : tree need_device_ptr_list = NULL_TREE;
10335 202 : tree need_device_addr_list = NULL_TREE;
10336 202 : tree append_args_tree = NULL_TREE;
10337 202 : tree id = get_identifier ("omp declare variant base");
10338 202 : tree variant = gfc_get_symbol_decl (variant_proc_sym);
10339 202 : DECL_ATTRIBUTES (base_fn_decl)
10340 202 : = tree_cons (id, build_tree_list (variant, set_selectors),
10341 202 : DECL_ATTRIBUTES (base_fn_decl));
10342 202 : int arg_idx_offset = 0;
10343 202 : if (gfc_return_by_reference (ns->proc_name))
10344 : {
10345 2 : arg_idx_offset++;
10346 2 : if (ns->proc_name->ts.type == BT_CHARACTER)
10347 2 : arg_idx_offset++;
10348 : }
10349 202 : int nargs = 0;
10350 202 : for (gfc_formal_arglist *arg
10351 202 : = gfc_sym_get_dummy_args (ns->proc_name);
10352 443 : arg; arg = arg->next)
10353 241 : nargs++;
10354 202 : if (odv->append_args_list)
10355 : {
10356 14 : int append_arg_no = arg_idx_offset + nargs;
10357 14 : tree last_arg = NULL_TREE;
10358 14 : for (gfc_omp_namelist *n = odv->append_args_list;
10359 43 : n != NULL; n = n->next)
10360 : {
10361 29 : tree pref = NULL_TREE;
10362 29 : if (n->u.init.len)
10363 : {
10364 22 : pref = build_string (n->u.init.len,
10365 11 : n->u2.init_interop);
10366 11 : TREE_TYPE (pref) = build_array_type_nelts (
10367 : unsigned_char_type_node,
10368 11 : n->u.init.len);
10369 : }
10370 : /* Save location, (target + target sync) and
10371 : prefer_type list in a tree list. */
10372 29 : tree t = build_tree_list (n->u.init.target
10373 : ? boolean_true_node
10374 : : boolean_false_node,
10375 29 : n->u.init.targetsync
10376 : ? boolean_true_node
10377 : : boolean_false_node);
10378 29 : t = build1_loc (gfc_get_location (&n->where),
10379 : NOP_EXPR, void_type_node, t);
10380 29 : t = build_tree_list (t, pref);
10381 29 : if (append_args_tree)
10382 : {
10383 15 : TREE_CHAIN (last_arg) = t;
10384 15 : last_arg = t;
10385 : }
10386 : else
10387 : append_args_tree = last_arg = t;
10388 : }
10389 : /* Store as 'purpose' = arg number to be used for inserting
10390 : and 'value' = list of interop items. */
10391 14 : append_args_tree = build_tree_list (
10392 : build_int_cst (integer_type_node,
10393 14 : append_arg_no),
10394 : append_args_tree);
10395 : }
10396 202 : vec<gfc_symbol *> adjust_args_list = vNULL;
10397 202 : for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
10398 312 : arg_list != NULL; arg_list = arg_list->next)
10399 : {
10400 110 : int from, to;
10401 110 : if (arg_list->expr == NULL || arg_list->sym)
10402 204 : from = ((arg_list->u.adj_args.omp_num_args_minus
10403 94 : || arg_list->u.adj_args.omp_num_args_plus)
10404 94 : ? nargs : 1);
10405 : else
10406 : {
10407 16 : if (arg_list->u.adj_args.omp_num_args_plus)
10408 0 : mpz_add_ui (arg_list->expr->value.integer,
10409 0 : arg_list->expr->value.integer, nargs);
10410 16 : if (arg_list->u.adj_args.omp_num_args_minus)
10411 2 : mpz_ui_sub (arg_list->expr->value.integer, nargs,
10412 2 : arg_list->expr->value.integer);
10413 16 : if (mpz_sgn (arg_list->expr->value.integer) <= 0)
10414 : {
10415 1 : gfc_warning (OPT_Wopenmp,
10416 : "Expected positive argument index "
10417 : "at %L", &arg_list->where);
10418 1 : from = 1;
10419 : }
10420 : else
10421 15 : from
10422 15 : = (mpz_fits_sint_p (arg_list->expr->value.integer)
10423 15 : ? mpz_get_si (arg_list->expr->value.integer)
10424 : : INT_MAX);
10425 16 : if (from > nargs)
10426 1 : gfc_warning (OPT_Wopenmp,
10427 : "Argument index at %L exceeds number "
10428 : "of arguments %d", &arg_list->where,
10429 : nargs);
10430 : }
10431 110 : locus loc = arg_list->where;
10432 110 : if (!arg_list->u.adj_args.range_start)
10433 : to = from;
10434 : else
10435 : {
10436 6 : loc = gfc_get_location_range (&arg_list->where, 0,
10437 : &arg_list->where, 0,
10438 6 : &arg_list->next->where);
10439 6 : if (arg_list->next->expr == NULL)
10440 : to = nargs;
10441 : else
10442 : {
10443 4 : if (arg_list->next->u.adj_args.omp_num_args_plus)
10444 0 : mpz_add_ui (arg_list->next->expr->value.integer,
10445 0 : arg_list->next->expr->value.integer,
10446 : nargs);
10447 4 : if (arg_list->next->u.adj_args.omp_num_args_minus)
10448 2 : mpz_ui_sub (arg_list->next->expr->value.integer,
10449 : nargs,
10450 2 : arg_list->next->expr->value.integer);
10451 4 : if (mpz_sgn (arg_list->next->expr->value.integer)
10452 : <= 0)
10453 : {
10454 0 : gfc_warning (OPT_Wopenmp,
10455 : "Expected positive argument "
10456 : "index at %L", &loc);
10457 0 : to = 0;
10458 : }
10459 : else
10460 4 : to = mpz_get_si (
10461 4 : arg_list->next->expr->value.integer);
10462 : }
10463 6 : if (from > to && to != 0)
10464 1 : gfc_warning (OPT_Wopenmp,
10465 : "Upper argument index smaller than "
10466 : "lower one at %L", &loc);
10467 6 : if (to > nargs)
10468 : to = nargs;
10469 6 : arg_list = arg_list->next;
10470 : }
10471 110 : if (from > nargs)
10472 1 : continue;
10473 : /* Change to zero based index. */
10474 109 : from--; to--;
10475 109 : gfc_formal_arglist *arg = ns->proc_name->formal;
10476 109 : if (!arg_list->sym && to >= from)
10477 35 : for (int idx = 0; idx < from; idx++)
10478 18 : arg = arg->next;
10479 223 : for (int idx = from; idx <= to; idx++)
10480 : {
10481 114 : if (idx > from)
10482 6 : arg = arg->next;
10483 114 : if (arg_list->sym)
10484 : {
10485 91 : for (arg = ns->proc_name->formal, idx = 0;
10486 201 : arg != NULL; arg = arg->next, idx++)
10487 200 : if (arg->sym == arg_list->sym)
10488 : break;
10489 91 : if (!arg || !arg_list->sym->attr.dummy)
10490 : {
10491 1 : gfc_error ("List item %qs at %L, declared at "
10492 : "%L, is not a dummy argument",
10493 : arg_list->sym->name, &loc,
10494 : &arg_list->sym->declared_at);
10495 1 : continue;
10496 : }
10497 : }
10498 113 : if (arg_list->u.adj_args.need_ptr
10499 82 : && (arg->sym->ts.f90_type != BT_VOID
10500 80 : || !arg->sym->ts.u.derived->ts.is_iso_c
10501 80 : || (arg->sym->ts.u.derived->intmod_sym_id
10502 : != ISOCBINDING_PTR)
10503 79 : || arg->sym->attr.dimension))
10504 : {
10505 6 : gfc_error ("Argument %qs at %L to list item in "
10506 : "%<need_device_ptr%> at %L must be a "
10507 : "scalar of TYPE(C_PTR)",
10508 : arg->sym->name,
10509 : &arg->sym->declared_at, &loc);
10510 6 : if (!arg->sym->attr.value)
10511 6 : inform (gfc_get_location (&loc),
10512 : "Consider using %<need_device_addr%> "
10513 : "instead");
10514 6 : continue;
10515 : }
10516 107 : if (arg_list->u.adj_args.need_addr
10517 11 : && arg->sym->attr.value)
10518 : {
10519 1 : gfc_error ("Argument %qs at %L to list item in "
10520 : "%<need_device_addr%> at %L must not "
10521 : "have the VALUE attribute",
10522 : arg->sym->name,
10523 : &arg->sym->declared_at, &loc);
10524 1 : continue;
10525 : }
10526 106 : if (adjust_args_list.contains (arg->sym))
10527 : {
10528 7 : gfc_error ("%qs at %L is specified more than "
10529 7 : "once", arg->sym->name, &loc);
10530 7 : continue;
10531 : }
10532 99 : adjust_args_list.safe_push (arg->sym);
10533 :
10534 99 : if (arg_list->u.adj_args.need_addr)
10535 : {
10536 : /* TODO: Has to to support OPTIONAL and array
10537 : descriptors; should check for CLASS, coarrays?
10538 : Reject "abc" and 123 as actual arguments (in
10539 : gimplify.cc or in the FE? Reject noncontiguous
10540 : actuals? Cf. also PR C++/118859.
10541 : Also check array-valued type(c_ptr). */
10542 7 : static bool warned = false;
10543 7 : if (!warned)
10544 1 : sorry_at (gfc_get_location (&loc),
10545 : "%<need_device_addr%> not yet "
10546 : "supported");
10547 7 : warned = true;
10548 7 : continue;
10549 7 : }
10550 92 : if (arg_list->u.adj_args.need_ptr
10551 : || arg_list->u.adj_args.need_addr)
10552 : {
10553 : // Store 0-based argument index,
10554 : // as in gimplify_call_expr
10555 74 : tree t
10556 74 : = build_tree_list (
10557 : NULL_TREE,
10558 : build_int_cst (integer_type_node,
10559 74 : idx + arg_idx_offset));
10560 74 : if (arg_list->u.adj_args.need_ptr)
10561 74 : need_device_ptr_list
10562 74 : = chainon (need_device_ptr_list, t);
10563 : else
10564 0 : need_device_addr_list
10565 0 : = chainon (need_device_addr_list, t);
10566 : }
10567 : }
10568 : }
10569 202 : tree t = NULL_TREE;
10570 202 : if (need_device_ptr_list
10571 202 : || need_device_addr_list
10572 166 : || append_args_tree)
10573 : {
10574 50 : t = build_tree_list (need_device_ptr_list,
10575 : need_device_addr_list),
10576 50 : TREE_CHAIN (t) = append_args_tree;
10577 50 : DECL_ATTRIBUTES (variant) = tree_cons (
10578 : get_identifier ("omp declare variant variant args"), t,
10579 50 : DECL_ATTRIBUTES (variant));
10580 : }
10581 : }
10582 : }
10583 : }
10584 : }
10585 10566 : }
10586 :
10587 : /* Add ptr for tracking as being allocated by GOMP_alloc. */
10588 :
10589 : tree
10590 29 : gfc_omp_call_add_alloc (tree ptr)
10591 : {
10592 29 : static tree fn = NULL_TREE;
10593 29 : if (fn == NULL_TREE)
10594 : {
10595 6 : fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
10596 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10597 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10598 6 : fn = build_type_attribute_variant (fn, att);
10599 6 : fn = build_fn_decl ("GOMP_add_alloc", fn);
10600 : }
10601 29 : return build_call_expr_loc (input_location, fn, 1, ptr);
10602 : }
10603 :
10604 : /* Generated function returns true when it was tracked via GOMP_add_alloc and
10605 : removes it from the tracking. As called just before GOMP_free or omp_realloc
10606 : the pointer is or might become invalid, thus, it is always removed. */
10607 :
10608 : tree
10609 47 : gfc_omp_call_is_alloc (tree ptr)
10610 : {
10611 47 : static tree fn = NULL_TREE;
10612 47 : if (fn == NULL_TREE)
10613 : {
10614 6 : fn = build_function_type_list (boolean_type_node, ptr_type_node,
10615 : NULL_TREE);
10616 6 : tree att = build_tree_list (NULL_TREE, build_string (4, ". R "));
10617 6 : att = tree_cons (get_identifier ("fn spec"), att, TYPE_ATTRIBUTES (fn));
10618 6 : fn = build_type_attribute_variant (fn, att);
10619 6 : fn = build_fn_decl ("GOMP_is_alloc", fn);
10620 : }
10621 47 : return build_call_expr_loc (input_location, fn, 1, ptr);
10622 : }
10623 :
10624 : tree
10625 88 : gfc_trans_omp_metadirective (gfc_code *code)
10626 : {
10627 88 : gfc_omp_variant *variant = code->ext.omp_variants;
10628 :
10629 88 : tree metadirective_tree = make_node (OMP_METADIRECTIVE);
10630 88 : SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc));
10631 88 : TREE_TYPE (metadirective_tree) = void_type_node;
10632 88 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree) = NULL_TREE;
10633 :
10634 88 : tree tree_body = NULL_TREE;
10635 :
10636 283 : while (variant)
10637 : {
10638 195 : tree ctx = gfc_trans_omp_set_selector (variant->selectors,
10639 : variant->where);
10640 195 : ctx = omp_check_context_selector (gfc_get_location (&variant->where),
10641 : ctx, OMP_CTX_METADIRECTIVE);
10642 195 : if (ctx == error_mark_node)
10643 : return error_mark_node;
10644 :
10645 : /* If the selector doesn't match, drop the whole variant. */
10646 195 : if (!omp_context_selector_matches (ctx, NULL_TREE, false))
10647 : {
10648 23 : variant = variant->next;
10649 23 : continue;
10650 : }
10651 :
10652 172 : gfc_code *next_code = variant->code->next;
10653 172 : if (next_code && tree_body == NULL_TREE)
10654 18 : tree_body = gfc_trans_code (next_code);
10655 :
10656 172 : if (next_code)
10657 20 : variant->code->next = NULL;
10658 172 : tree directive = gfc_trans_code (variant->code);
10659 172 : if (next_code)
10660 20 : variant->code->next = next_code;
10661 :
10662 20 : tree body = next_code ? tree_body : NULL_TREE;
10663 172 : tree omp_variant = make_omp_metadirective_variant (ctx, directive, body);
10664 344 : OMP_METADIRECTIVE_VARIANTS (metadirective_tree)
10665 172 : = chainon (OMP_METADIRECTIVE_VARIANTS (metadirective_tree),
10666 : omp_variant);
10667 172 : variant = variant->next;
10668 : }
10669 :
10670 : /* TODO: Resolve the metadirective here if possible. */
10671 :
10672 : return metadirective_tree;
10673 : }
|
