1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2021 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek <jakub@redhat.com>
5 This file is part of GCC.
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
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
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/>. */
24 #include "coretypes.h"
28 #include "gimple-expr.h"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "gimplify.h" /* For create_tmp_var_raw. */
33 #include "trans-stmt.h"
34 #include "trans-types.h"
35 #include "trans-array.h"
36 #include "trans-const.h"
38 #include "constructor.h"
39 #include "gomp-constants.h"
40 #include "omp-general.h"
42 #include "memmodel.h" /* For MEMMODEL_ enums. */
45 #define GCC_DIAG_STYLE __gcc_tdiag__
46 #include "diagnostic-core.h"
48 #define GCC_DIAG_STYLE __gcc_gfc__
54 /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
55 allocatable or pointer attribute. */
58 gfc_omp_is_allocatable_or_ptr (const_tree decl
)
61 && (GFC_DECL_GET_SCALAR_POINTER (decl
)
62 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)));
65 /* True if the argument is an optional argument; except that false is also
66 returned for arguments with the value attribute (nonpointers) and for
67 assumed-shape variables (decl is a local variable containing arg->data).
68 Note that for 'procedure(), optional' the value false is used as that's
69 always a pointer and no additional indirection is used.
70 Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
73 gfc_omp_is_optional_argument (const_tree decl
)
75 return (TREE_CODE (decl
) == PARM_DECL
76 && DECL_LANG_SPECIFIC (decl
)
77 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
78 && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
79 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) != FUNCTION_TYPE
80 && GFC_DECL_OPTIONAL_ARGUMENT (decl
));
83 /* Check whether this DECL belongs to a Fortran optional argument.
84 With 'for_present_check' set to false, decls which are optional parameters
85 themselve are returned as tree - or a NULL_TREE otherwise. Those decls are
86 always pointers. With 'for_present_check' set to true, the decl for checking
87 whether an argument is present is returned; for arguments with value
88 attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
89 unrelated to optional arguments, NULL_TREE is returned. */
92 gfc_omp_check_optional_argument (tree decl
, bool for_present_check
)
94 if (!for_present_check
)
95 return gfc_omp_is_optional_argument (decl
) ? decl
: NULL_TREE
;
97 if (!DECL_LANG_SPECIFIC (decl
))
100 tree orig_decl
= decl
;
102 /* For assumed-shape arrays, a local decl with arg->data is used. */
103 if (TREE_CODE (decl
) != PARM_DECL
104 && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
105 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))))
106 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
108 if (decl
== NULL_TREE
109 || TREE_CODE (decl
) != PARM_DECL
110 || !DECL_LANG_SPECIFIC (decl
)
111 || !GFC_DECL_OPTIONAL_ARGUMENT (decl
))
114 /* Scalars with VALUE attribute which are passed by value use a hidden
115 argument to denote the present status. They are passed as nonpointer type
116 with one exception: 'type(c_ptr), value' as 'void*'. */
117 /* Cf. trans-expr.c's gfc_conv_expr_present. */
118 if (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
119 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
121 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
125 strcpy (&name
[1], IDENTIFIER_POINTER (DECL_NAME (decl
)));
126 tree_name
= get_identifier (name
);
128 /* Walk function argument list to find the hidden arg. */
129 decl
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
130 for ( ; decl
!= NULL_TREE
; decl
= TREE_CHAIN (decl
))
131 if (DECL_NAME (decl
) == tree_name
132 && DECL_ARTIFICIAL (decl
))
139 return fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
140 orig_decl
, null_pointer_node
);
144 /* Returns tree with NULL if it is not an array descriptor and with the tree to
145 access the 'data' component otherwise. With type_only = true, it returns the
146 TREE_TYPE without creating a new tree. */
149 gfc_omp_array_data (tree decl
, bool type_only
)
151 tree type
= TREE_TYPE (decl
);
153 if (POINTER_TYPE_P (type
))
154 type
= TREE_TYPE (type
);
156 if (!GFC_DESCRIPTOR_TYPE_P (type
))
160 return GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
162 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
163 decl
= build_fold_indirect_ref (decl
);
165 decl
= gfc_conv_descriptor_data_get (decl
);
170 /* True if OpenMP should privatize what this DECL points to rather
171 than the DECL itself. */
174 gfc_omp_privatize_by_reference (const_tree decl
)
176 tree type
= TREE_TYPE (decl
);
178 if (TREE_CODE (type
) == REFERENCE_TYPE
179 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
182 if (TREE_CODE (type
) == POINTER_TYPE
183 && gfc_omp_is_optional_argument (decl
))
186 if (TREE_CODE (type
) == POINTER_TYPE
)
188 while (TREE_CODE (decl
) == COMPONENT_REF
)
189 decl
= TREE_OPERAND (decl
, 1);
191 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
192 that have POINTER_TYPE type and aren't scalar pointers, scalar
193 allocatables, Cray pointees or C pointers are supposed to be
194 privatized by reference. */
195 if (GFC_DECL_GET_SCALAR_POINTER (decl
)
196 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
197 || GFC_DECL_CRAY_POINTEE (decl
)
198 || GFC_DECL_ASSOCIATE_VAR_P (decl
)
199 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
202 if (!DECL_ARTIFICIAL (decl
)
203 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
206 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
208 if (DECL_LANG_SPECIFIC (decl
)
209 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
216 /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
217 of DECL is predetermined. */
219 enum omp_clause_default_kind
220 gfc_omp_predetermined_sharing (tree decl
)
222 /* Associate names preserve the association established during ASSOCIATE.
223 As they are implemented either as pointers to the selector or array
224 descriptor and shouldn't really change in the ASSOCIATE region,
225 this decl can be either shared or firstprivate. If it is a pointer,
226 use firstprivate, as it is cheaper that way, otherwise make it shared. */
227 if (GFC_DECL_ASSOCIATE_VAR_P (decl
))
229 if (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
230 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
232 return OMP_CLAUSE_DEFAULT_SHARED
;
235 if (DECL_ARTIFICIAL (decl
)
236 && ! GFC_DECL_RESULT (decl
)
237 && ! (DECL_LANG_SPECIFIC (decl
)
238 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
239 return OMP_CLAUSE_DEFAULT_SHARED
;
241 /* Cray pointees shouldn't be listed in any clauses and should be
242 gimplified to dereference of the corresponding Cray pointer.
243 Make them all private, so that they are emitted in the debug
245 if (GFC_DECL_CRAY_POINTEE (decl
))
246 return OMP_CLAUSE_DEFAULT_PRIVATE
;
248 /* Assumed-size arrays are predetermined shared. */
249 if (TREE_CODE (decl
) == PARM_DECL
250 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
251 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
252 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
253 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
255 return OMP_CLAUSE_DEFAULT_SHARED
;
257 /* Dummy procedures aren't considered variables by OpenMP, thus are
258 disallowed in OpenMP clauses. They are represented as PARM_DECLs
259 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
260 to avoid complaining about their uses with default(none). */
261 if (TREE_CODE (decl
) == PARM_DECL
262 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
263 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
264 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
266 /* COMMON and EQUIVALENCE decls are shared. They
267 are only referenced through DECL_VALUE_EXPR of the variables
268 contained in them. If those are privatized, they will not be
269 gimplified to the COMMON or EQUIVALENCE decls. */
270 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
271 return OMP_CLAUSE_DEFAULT_SHARED
;
273 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
274 return OMP_CLAUSE_DEFAULT_SHARED
;
276 /* These are either array or derived parameters, or vtables.
277 In the former cases, the OpenMP standard doesn't consider them to be
278 variables at all (they can't be redefined), but they can nevertheless appear
279 in parallel/task regions and for default(none) purposes treat them as shared.
280 For vtables likely the same handling is desirable. */
281 if (VAR_P (decl
) && TREE_READONLY (decl
)
282 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
283 return OMP_CLAUSE_DEFAULT_SHARED
;
285 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
289 /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
290 of DECL is predetermined. */
292 enum omp_clause_defaultmap_kind
293 gfc_omp_predetermined_mapping (tree decl
)
295 if (DECL_ARTIFICIAL (decl
)
296 && ! GFC_DECL_RESULT (decl
)
297 && ! (DECL_LANG_SPECIFIC (decl
)
298 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
299 return OMP_CLAUSE_DEFAULTMAP_TO
;
301 /* These are either array or derived parameters, or vtables. */
302 if (VAR_P (decl
) && TREE_READONLY (decl
)
303 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
304 return OMP_CLAUSE_DEFAULTMAP_TO
;
306 return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED
;
310 /* Return decl that should be used when reporting DEFAULT(NONE)
314 gfc_omp_report_decl (tree decl
)
316 if (DECL_ARTIFICIAL (decl
)
317 && DECL_LANG_SPECIFIC (decl
)
318 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
319 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
324 /* Return true if TYPE has any allocatable components. */
327 gfc_has_alloc_comps (tree type
, tree decl
)
331 if (POINTER_TYPE_P (type
))
333 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
334 type
= TREE_TYPE (type
);
335 else if (GFC_DECL_GET_SCALAR_POINTER (decl
))
339 if (GFC_DESCRIPTOR_TYPE_P (type
)
340 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
341 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
344 if (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
))
345 type
= gfc_get_element_type (type
);
347 if (TREE_CODE (type
) != RECORD_TYPE
)
350 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
352 ftype
= TREE_TYPE (field
);
353 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
355 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
356 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
358 if (gfc_has_alloc_comps (ftype
, field
))
364 /* Return true if TYPE is polymorphic but not with pointer attribute. */
367 gfc_is_polymorphic_nonptr (tree type
)
369 if (POINTER_TYPE_P (type
))
370 type
= TREE_TYPE (type
);
371 return GFC_CLASS_TYPE_P (type
);
374 /* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
375 unlimited means also intrinsic types are handled and _len is used. */
378 gfc_is_unlimited_polymorphic_nonptr (tree type
)
380 if (POINTER_TYPE_P (type
))
381 type
= TREE_TYPE (type
);
382 if (!GFC_CLASS_TYPE_P (type
))
385 tree field
= TYPE_FIELDS (type
); /* _data */
387 field
= DECL_CHAIN (field
); /* _vptr */
389 field
= DECL_CHAIN (field
);
392 gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field
))) == 0);
396 /* Return true if the DECL is for an allocatable array or scalar. */
399 gfc_omp_allocatable_p (tree decl
)
404 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
407 tree type
= TREE_TYPE (decl
);
408 if (gfc_omp_privatize_by_reference (decl
))
409 type
= TREE_TYPE (type
);
411 if (GFC_DESCRIPTOR_TYPE_P (type
)
412 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
419 /* Return true if DECL in private clause needs
420 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
422 gfc_omp_private_outer_ref (tree decl
)
424 tree type
= TREE_TYPE (decl
);
426 if (gfc_omp_privatize_by_reference (decl
))
427 type
= TREE_TYPE (type
);
429 if (GFC_DESCRIPTOR_TYPE_P (type
)
430 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
433 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
436 if (gfc_has_alloc_comps (type
, decl
))
442 /* Callback for gfc_omp_unshare_expr. */
445 gfc_omp_unshare_expr_r (tree
*tp
, int *walk_subtrees
, void *)
448 enum tree_code code
= TREE_CODE (t
);
450 /* Stop at types, decls, constants like copy_tree_r. */
451 if (TREE_CODE_CLASS (code
) == tcc_type
452 || TREE_CODE_CLASS (code
) == tcc_declaration
453 || TREE_CODE_CLASS (code
) == tcc_constant
456 else if (handled_component_p (t
)
457 || TREE_CODE (t
) == MEM_REF
)
459 *tp
= unshare_expr (t
);
466 /* Unshare in expr anything that the FE which normally doesn't
467 care much about tree sharing (because during gimplification
468 everything is unshared) could cause problems with tree sharing
469 at omp-low.c time. */
472 gfc_omp_unshare_expr (tree expr
)
474 walk_tree (&expr
, gfc_omp_unshare_expr_r
, NULL
, NULL
);
478 enum walk_alloc_comps
480 WALK_ALLOC_COMPS_DTOR
,
481 WALK_ALLOC_COMPS_DEFAULT_CTOR
,
482 WALK_ALLOC_COMPS_COPY_CTOR
485 /* Handle allocatable components in OpenMP clauses. */
488 gfc_walk_alloc_comps (tree decl
, tree dest
, tree var
,
489 enum walk_alloc_comps kind
)
491 stmtblock_t block
, tmpblock
;
492 tree type
= TREE_TYPE (decl
), then_b
, tem
, field
;
493 gfc_init_block (&block
);
495 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
497 if (GFC_DESCRIPTOR_TYPE_P (type
))
499 gfc_init_block (&tmpblock
);
500 tem
= gfc_full_array_size (&tmpblock
, decl
,
501 GFC_TYPE_ARRAY_RANK (type
));
502 then_b
= gfc_finish_block (&tmpblock
);
503 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (then_b
));
504 tem
= gfc_omp_unshare_expr (tem
);
505 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
506 gfc_array_index_type
, tem
,
511 bool compute_nelts
= false;
512 if (!TYPE_DOMAIN (type
)
513 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
514 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
515 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
516 compute_nelts
= true;
517 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
519 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
520 if (lookup_attribute ("omp dummy var", a
))
521 compute_nelts
= true;
525 tem
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
526 TYPE_SIZE_UNIT (type
),
527 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
528 tem
= size_binop (MINUS_EXPR
, tem
, size_one_node
);
531 tem
= array_type_nelts (type
);
532 tem
= fold_convert (gfc_array_index_type
, tem
);
535 tree nelems
= gfc_evaluate_now (tem
, &block
);
536 tree index
= gfc_create_var (gfc_array_index_type
, "S");
538 gfc_init_block (&tmpblock
);
539 tem
= gfc_conv_array_data (decl
);
540 tree declvar
= build_fold_indirect_ref_loc (input_location
, tem
);
541 tree declvref
= gfc_build_array_ref (declvar
, index
, NULL
);
542 tree destvar
, destvref
= NULL_TREE
;
545 tem
= gfc_conv_array_data (dest
);
546 destvar
= build_fold_indirect_ref_loc (input_location
, tem
);
547 destvref
= gfc_build_array_ref (destvar
, index
, NULL
);
549 gfc_add_expr_to_block (&tmpblock
,
550 gfc_walk_alloc_comps (declvref
, destvref
,
554 gfc_init_loopinfo (&loop
);
556 loop
.from
[0] = gfc_index_zero_node
;
557 loop
.loopvar
[0] = index
;
559 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
560 gfc_add_block_to_block (&block
, &loop
.pre
);
561 return gfc_finish_block (&block
);
563 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var
))
565 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
567 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
568 type
= TREE_TYPE (decl
);
571 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
572 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
574 tree ftype
= TREE_TYPE (field
);
575 tree declf
, destf
= NULL_TREE
;
576 bool has_alloc_comps
= gfc_has_alloc_comps (ftype
, field
);
577 if ((!GFC_DESCRIPTOR_TYPE_P (ftype
)
578 || GFC_TYPE_ARRAY_AKIND (ftype
) != GFC_ARRAY_ALLOCATABLE
)
579 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field
)
582 declf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
583 decl
, field
, NULL_TREE
);
585 destf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
586 dest
, field
, NULL_TREE
);
591 case WALK_ALLOC_COMPS_DTOR
:
593 case WALK_ALLOC_COMPS_DEFAULT_CTOR
:
594 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
595 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
597 gfc_add_modify (&block
, unshare_expr (destf
),
598 unshare_expr (declf
));
599 tem
= gfc_duplicate_allocatable_nocopy
600 (destf
, declf
, ftype
,
601 GFC_TYPE_ARRAY_RANK (ftype
));
603 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
604 tem
= gfc_duplicate_allocatable_nocopy (destf
, declf
, ftype
, 0);
606 case WALK_ALLOC_COMPS_COPY_CTOR
:
607 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
608 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
609 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
,
610 GFC_TYPE_ARRAY_RANK (ftype
),
612 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
613 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
, 0,
618 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
621 gfc_init_block (&tmpblock
);
622 gfc_add_expr_to_block (&tmpblock
,
623 gfc_walk_alloc_comps (declf
, destf
,
625 then_b
= gfc_finish_block (&tmpblock
);
626 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
627 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
628 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
629 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
630 tem
= unshare_expr (declf
);
635 tem
= fold_convert (pvoid_type_node
, tem
);
636 tem
= fold_build2_loc (input_location
, NE_EXPR
,
637 logical_type_node
, tem
,
639 then_b
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
641 build_empty_stmt (input_location
));
643 gfc_add_expr_to_block (&block
, then_b
);
645 if (kind
== WALK_ALLOC_COMPS_DTOR
)
647 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
648 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
650 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
651 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
,
652 NULL_TREE
, NULL_TREE
, true,
654 GFC_CAF_COARRAY_NOCOARRAY
);
655 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
657 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
659 tem
= gfc_call_free (unshare_expr (declf
));
660 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
665 return gfc_finish_block (&block
);
668 /* Return code to initialize DECL with its default constructor, or
669 NULL if there's nothing to do. */
672 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
674 tree type
= TREE_TYPE (decl
), size
, ptr
, cond
, then_b
, else_b
;
675 stmtblock_t block
, cond_block
;
677 switch (OMP_CLAUSE_CODE (clause
))
679 case OMP_CLAUSE__LOOPTEMP_
:
680 case OMP_CLAUSE__REDUCTEMP_
:
681 case OMP_CLAUSE__CONDTEMP_
:
682 case OMP_CLAUSE__SCANTEMP_
:
684 case OMP_CLAUSE_PRIVATE
:
685 case OMP_CLAUSE_LASTPRIVATE
:
686 case OMP_CLAUSE_LINEAR
:
687 case OMP_CLAUSE_REDUCTION
:
688 case OMP_CLAUSE_IN_REDUCTION
:
689 case OMP_CLAUSE_TASK_REDUCTION
:
695 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
696 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
697 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
698 || !POINTER_TYPE_P (type
)))
700 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
703 gfc_start_block (&block
);
704 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
705 OMP_CLAUSE_DECL (clause
),
706 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
707 gfc_add_expr_to_block (&block
, tem
);
708 return gfc_finish_block (&block
);
713 gcc_assert (outer
!= NULL_TREE
);
715 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
716 "not currently allocated" allocation status if outer
717 array is "not currently allocated", otherwise should be allocated. */
718 gfc_start_block (&block
);
720 gfc_init_block (&cond_block
);
722 if (GFC_DESCRIPTOR_TYPE_P (type
))
724 gfc_add_modify (&cond_block
, decl
, outer
);
725 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
726 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
727 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
729 gfc_conv_descriptor_lbound_get (decl
, rank
));
730 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
731 size
, gfc_index_one_node
);
732 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
733 size
= fold_build2_loc (input_location
, MULT_EXPR
,
734 gfc_array_index_type
, size
,
735 gfc_conv_descriptor_stride_get (decl
, rank
));
736 tree esize
= fold_convert (gfc_array_index_type
,
737 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
738 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
740 size
= unshare_expr (size
);
741 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
745 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
746 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
747 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
748 if (GFC_DESCRIPTOR_TYPE_P (type
))
749 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
), ptr
);
751 gfc_add_modify (&cond_block
, unshare_expr (decl
),
752 fold_convert (TREE_TYPE (decl
), ptr
));
753 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
755 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
756 OMP_CLAUSE_DECL (clause
),
757 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
758 gfc_add_expr_to_block (&cond_block
, tem
);
760 then_b
= gfc_finish_block (&cond_block
);
762 /* Reduction clause requires allocated ALLOCATABLE. */
763 if (OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_REDUCTION
764 && OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_IN_REDUCTION
765 && OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_TASK_REDUCTION
)
767 gfc_init_block (&cond_block
);
768 if (GFC_DESCRIPTOR_TYPE_P (type
))
769 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
),
772 gfc_add_modify (&cond_block
, unshare_expr (decl
),
773 build_zero_cst (TREE_TYPE (decl
)));
774 else_b
= gfc_finish_block (&cond_block
);
776 tree tem
= fold_convert (pvoid_type_node
,
777 GFC_DESCRIPTOR_TYPE_P (type
)
778 ? gfc_conv_descriptor_data_get (outer
) : outer
);
779 tem
= unshare_expr (tem
);
780 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
781 tem
, null_pointer_node
);
782 gfc_add_expr_to_block (&block
,
783 build3_loc (input_location
, COND_EXPR
,
784 void_type_node
, cond
, then_b
,
786 /* Avoid -W*uninitialized warnings. */
788 suppress_warning (decl
, OPT_Wuninitialized
);
791 gfc_add_expr_to_block (&block
, then_b
);
793 return gfc_finish_block (&block
);
796 /* Build and return code for a copy constructor from SRC to DEST. */
799 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
801 tree type
= TREE_TYPE (dest
), ptr
, size
, call
;
802 tree decl_type
= TREE_TYPE (OMP_CLAUSE_DECL (clause
));
803 tree cond
, then_b
, else_b
;
804 stmtblock_t block
, cond_block
;
806 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
807 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
809 if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause
))
810 && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause
))
811 && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause
)))
813 = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause
)));
815 if (gfc_is_polymorphic_nonptr (decl_type
))
817 if (POINTER_TYPE_P (decl_type
))
818 decl_type
= TREE_TYPE (decl_type
);
819 decl_type
= TREE_TYPE (TYPE_FIELDS (decl_type
));
820 if (GFC_DESCRIPTOR_TYPE_P (decl_type
) || GFC_ARRAY_TYPE_P (decl_type
))
821 fatal_error (input_location
,
822 "Sorry, polymorphic arrays not yet supported for "
825 tree nelems
= build_int_cst (size_type_node
, 1); /* Scalar. */
826 tree src_data
= gfc_class_data_get (unshare_expr (src
));
827 tree dest_data
= gfc_class_data_get (unshare_expr (dest
));
828 bool unlimited
= gfc_is_unlimited_polymorphic_nonptr (type
);
830 gfc_start_block (&block
);
831 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
832 gfc_class_vptr_get (src
));
833 gfc_init_block (&cond_block
);
837 src_len
= gfc_class_len_get (src
);
838 gfc_add_modify (&cond_block
, gfc_class_len_get (unshare_expr (dest
)), src_len
);
841 /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
842 size
= fold_convert (size_type_node
, gfc_class_vtab_size_get (src
));
845 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
846 unshare_expr (src_len
),
847 build_zero_cst (TREE_TYPE (src_len
)));
848 cond
= build3_loc (input_location
, COND_EXPR
, size_type_node
, cond
,
849 fold_convert (size_type_node
,
850 unshare_expr (src_len
)),
851 build_int_cst (size_type_node
, 1));
852 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
856 /* Malloc memory + call class->_vpt->_copy. */
857 call
= builtin_decl_explicit (BUILT_IN_MALLOC
);
858 call
= build_call_expr_loc (input_location
, call
, 1, size
);
859 gfc_add_modify (&cond_block
, dest_data
,
860 fold_convert (TREE_TYPE (dest_data
), call
));
861 gfc_add_expr_to_block (&cond_block
,
862 gfc_copy_class_to_class (src
, dest
, nelems
,
865 gcc_assert (TREE_CODE (dest_data
) == COMPONENT_REF
);
866 if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data
, 1)))
868 gfc_add_block_to_block (&block
, &cond_block
);
872 /* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
873 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
874 src_data
, null_pointer_node
);
875 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
876 void_type_node
, cond
,
877 gfc_finish_block (&cond_block
),
878 fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
879 unshare_expr (dest_data
), null_pointer_node
)));
881 return gfc_finish_block (&block
);
884 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
885 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
886 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
887 || !POINTER_TYPE_P (type
)))
889 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
891 gfc_start_block (&block
);
892 gfc_add_modify (&block
, dest
, src
);
893 tree tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
894 WALK_ALLOC_COMPS_COPY_CTOR
);
895 gfc_add_expr_to_block (&block
, tem
);
896 return gfc_finish_block (&block
);
899 return build2_v (MODIFY_EXPR
, dest
, src
);
902 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
903 and copied from SRC. */
904 gfc_start_block (&block
);
906 gfc_init_block (&cond_block
);
908 gfc_add_modify (&cond_block
, dest
, fold_convert (TREE_TYPE (dest
), src
));
909 if (GFC_DESCRIPTOR_TYPE_P (type
))
911 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
912 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
913 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
915 gfc_conv_descriptor_lbound_get (dest
, rank
));
916 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
917 size
, gfc_index_one_node
);
918 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
919 size
= fold_build2_loc (input_location
, MULT_EXPR
,
920 gfc_array_index_type
, size
,
921 gfc_conv_descriptor_stride_get (dest
, rank
));
922 tree esize
= fold_convert (gfc_array_index_type
,
923 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
924 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
926 size
= unshare_expr (size
);
927 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
931 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
932 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
933 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
934 if (GFC_DESCRIPTOR_TYPE_P (type
))
935 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
), ptr
);
937 gfc_add_modify (&cond_block
, unshare_expr (dest
),
938 fold_convert (TREE_TYPE (dest
), ptr
));
940 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
941 ? gfc_conv_descriptor_data_get (src
) : src
;
942 srcptr
= unshare_expr (srcptr
);
943 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
944 call
= build_call_expr_loc (input_location
,
945 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
947 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
948 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
950 tree tem
= gfc_walk_alloc_comps (src
, dest
,
951 OMP_CLAUSE_DECL (clause
),
952 WALK_ALLOC_COMPS_COPY_CTOR
);
953 gfc_add_expr_to_block (&cond_block
, tem
);
955 then_b
= gfc_finish_block (&cond_block
);
957 gfc_init_block (&cond_block
);
958 if (GFC_DESCRIPTOR_TYPE_P (type
))
959 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
),
962 gfc_add_modify (&cond_block
, unshare_expr (dest
),
963 build_zero_cst (TREE_TYPE (dest
)));
964 else_b
= gfc_finish_block (&cond_block
);
966 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
967 unshare_expr (srcptr
), null_pointer_node
);
968 gfc_add_expr_to_block (&block
,
969 build3_loc (input_location
, COND_EXPR
,
970 void_type_node
, cond
, then_b
, else_b
));
971 /* Avoid -W*uninitialized warnings. */
973 suppress_warning (dest
, OPT_Wuninitialized
);
975 return gfc_finish_block (&block
);
978 /* Similarly, except use an intrinsic or pointer assignment operator
982 gfc_omp_clause_assign_op (tree clause
, tree dest
, tree src
)
984 tree type
= TREE_TYPE (dest
), ptr
, size
, call
, nonalloc
;
985 tree cond
, then_b
, else_b
;
986 stmtblock_t block
, cond_block
, cond_block2
, inner_block
;
988 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
989 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
990 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
991 || !POINTER_TYPE_P (type
)))
993 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
995 gfc_start_block (&block
);
996 /* First dealloc any allocatable components in DEST. */
997 tree tem
= gfc_walk_alloc_comps (dest
, NULL_TREE
,
998 OMP_CLAUSE_DECL (clause
),
999 WALK_ALLOC_COMPS_DTOR
);
1000 gfc_add_expr_to_block (&block
, tem
);
1001 /* Then copy over toplevel data. */
1002 gfc_add_modify (&block
, dest
, src
);
1003 /* Finally allocate any allocatable components and copy. */
1004 tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
1005 WALK_ALLOC_COMPS_COPY_CTOR
);
1006 gfc_add_expr_to_block (&block
, tem
);
1007 return gfc_finish_block (&block
);
1010 return build2_v (MODIFY_EXPR
, dest
, src
);
1013 gfc_start_block (&block
);
1015 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1017 then_b
= gfc_walk_alloc_comps (dest
, NULL_TREE
, OMP_CLAUSE_DECL (clause
),
1018 WALK_ALLOC_COMPS_DTOR
);
1019 tree tem
= fold_convert (pvoid_type_node
,
1020 GFC_DESCRIPTOR_TYPE_P (type
)
1021 ? gfc_conv_descriptor_data_get (dest
) : dest
);
1022 tem
= unshare_expr (tem
);
1023 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1024 tem
, null_pointer_node
);
1025 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1026 then_b
, build_empty_stmt (input_location
));
1027 gfc_add_expr_to_block (&block
, tem
);
1030 gfc_init_block (&cond_block
);
1032 if (GFC_DESCRIPTOR_TYPE_P (type
))
1034 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
1035 size
= gfc_conv_descriptor_ubound_get (src
, rank
);
1036 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1038 gfc_conv_descriptor_lbound_get (src
, rank
));
1039 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1040 size
, gfc_index_one_node
);
1041 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
1042 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1043 gfc_array_index_type
, size
,
1044 gfc_conv_descriptor_stride_get (src
, rank
));
1045 tree esize
= fold_convert (gfc_array_index_type
,
1046 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1047 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1049 size
= unshare_expr (size
);
1050 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
1054 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1055 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
1057 tree destptr
= GFC_DESCRIPTOR_TYPE_P (type
)
1058 ? gfc_conv_descriptor_data_get (dest
) : dest
;
1059 destptr
= unshare_expr (destptr
);
1060 destptr
= fold_convert (pvoid_type_node
, destptr
);
1061 gfc_add_modify (&cond_block
, ptr
, destptr
);
1063 nonalloc
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
1064 destptr
, null_pointer_node
);
1066 if (GFC_DESCRIPTOR_TYPE_P (type
))
1069 for (i
= 0; i
< GFC_TYPE_ARRAY_RANK (type
); i
++)
1071 tree rank
= gfc_rank_cst
[i
];
1072 tree tem
= gfc_conv_descriptor_ubound_get (src
, rank
);
1073 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
1074 gfc_array_index_type
, tem
,
1075 gfc_conv_descriptor_lbound_get (src
, rank
));
1076 tem
= fold_build2_loc (input_location
, PLUS_EXPR
,
1077 gfc_array_index_type
, tem
,
1078 gfc_conv_descriptor_lbound_get (dest
, rank
));
1079 tem
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1080 tem
, gfc_conv_descriptor_ubound_get (dest
,
1082 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1083 logical_type_node
, cond
, tem
);
1087 gfc_init_block (&cond_block2
);
1089 if (GFC_DESCRIPTOR_TYPE_P (type
))
1091 gfc_init_block (&inner_block
);
1092 gfc_allocate_using_malloc (&inner_block
, ptr
, size
, NULL_TREE
);
1093 then_b
= gfc_finish_block (&inner_block
);
1095 gfc_init_block (&inner_block
);
1096 gfc_add_modify (&inner_block
, ptr
,
1097 gfc_call_realloc (&inner_block
, ptr
, size
));
1098 else_b
= gfc_finish_block (&inner_block
);
1100 gfc_add_expr_to_block (&cond_block2
,
1101 build3_loc (input_location
, COND_EXPR
,
1103 unshare_expr (nonalloc
),
1105 gfc_add_modify (&cond_block2
, dest
, src
);
1106 gfc_conv_descriptor_data_set (&cond_block2
, unshare_expr (dest
), ptr
);
1110 gfc_allocate_using_malloc (&cond_block2
, ptr
, size
, NULL_TREE
);
1111 gfc_add_modify (&cond_block2
, unshare_expr (dest
),
1112 fold_convert (type
, ptr
));
1114 then_b
= gfc_finish_block (&cond_block2
);
1115 else_b
= build_empty_stmt (input_location
);
1117 gfc_add_expr_to_block (&cond_block
,
1118 build3_loc (input_location
, COND_EXPR
,
1119 void_type_node
, unshare_expr (cond
),
1122 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
1123 ? gfc_conv_descriptor_data_get (src
) : src
;
1124 srcptr
= unshare_expr (srcptr
);
1125 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
1126 call
= build_call_expr_loc (input_location
,
1127 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
1129 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
1130 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1132 tree tem
= gfc_walk_alloc_comps (src
, dest
,
1133 OMP_CLAUSE_DECL (clause
),
1134 WALK_ALLOC_COMPS_COPY_CTOR
);
1135 gfc_add_expr_to_block (&cond_block
, tem
);
1137 then_b
= gfc_finish_block (&cond_block
);
1139 if (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_COPYIN
)
1141 gfc_init_block (&cond_block
);
1142 if (GFC_DESCRIPTOR_TYPE_P (type
))
1144 tree tmp
= gfc_conv_descriptor_data_get (unshare_expr (dest
));
1145 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
1146 NULL_TREE
, NULL_TREE
, true, NULL
,
1147 GFC_CAF_COARRAY_NOCOARRAY
);
1148 gfc_add_expr_to_block (&cond_block
, tmp
);
1152 destptr
= gfc_evaluate_now (destptr
, &cond_block
);
1153 gfc_add_expr_to_block (&cond_block
, gfc_call_free (destptr
));
1154 gfc_add_modify (&cond_block
, unshare_expr (dest
),
1155 build_zero_cst (TREE_TYPE (dest
)));
1157 else_b
= gfc_finish_block (&cond_block
);
1159 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1160 unshare_expr (srcptr
), null_pointer_node
);
1161 gfc_add_expr_to_block (&block
,
1162 build3_loc (input_location
, COND_EXPR
,
1163 void_type_node
, cond
,
1167 gfc_add_expr_to_block (&block
, then_b
);
1169 return gfc_finish_block (&block
);
1173 gfc_omp_linear_clause_add_loop (stmtblock_t
*block
, tree dest
, tree src
,
1174 tree add
, tree nelems
)
1176 stmtblock_t tmpblock
;
1177 tree desta
, srca
, index
= gfc_create_var (gfc_array_index_type
, "S");
1178 nelems
= gfc_evaluate_now (nelems
, block
);
1180 gfc_init_block (&tmpblock
);
1181 if (TREE_CODE (TREE_TYPE (dest
)) == ARRAY_TYPE
)
1183 desta
= gfc_build_array_ref (dest
, index
, NULL
);
1184 srca
= gfc_build_array_ref (src
, index
, NULL
);
1188 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest
)));
1189 tree idx
= fold_build2 (MULT_EXPR
, sizetype
,
1190 fold_convert (sizetype
, index
),
1191 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest
))));
1192 desta
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1193 TREE_TYPE (dest
), dest
,
1195 srca
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1196 TREE_TYPE (src
), src
,
1199 gfc_add_modify (&tmpblock
, desta
,
1200 fold_build2 (PLUS_EXPR
, TREE_TYPE (desta
),
1204 gfc_init_loopinfo (&loop
);
1206 loop
.from
[0] = gfc_index_zero_node
;
1207 loop
.loopvar
[0] = index
;
1208 loop
.to
[0] = nelems
;
1209 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
1210 gfc_add_block_to_block (block
, &loop
.pre
);
1213 /* Build and return code for a constructor of DEST that initializes
1214 it to SRC plus ADD (ADD is scalar integer). */
1217 gfc_omp_clause_linear_ctor (tree clause
, tree dest
, tree src
, tree add
)
1219 tree type
= TREE_TYPE (dest
), ptr
, size
, nelems
= NULL_TREE
;
1222 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
1224 gfc_start_block (&block
);
1225 add
= gfc_evaluate_now (add
, &block
);
1227 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1228 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1229 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1230 || !POINTER_TYPE_P (type
)))
1232 bool compute_nelts
= false;
1233 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1234 if (!TYPE_DOMAIN (type
)
1235 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
1236 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
1237 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
1238 compute_nelts
= true;
1239 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
1241 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
1242 if (lookup_attribute ("omp dummy var", a
))
1243 compute_nelts
= true;
1247 nelems
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
1248 TYPE_SIZE_UNIT (type
),
1249 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1250 nelems
= size_binop (MINUS_EXPR
, nelems
, size_one_node
);
1253 nelems
= array_type_nelts (type
);
1254 nelems
= fold_convert (gfc_array_index_type
, nelems
);
1256 gfc_omp_linear_clause_add_loop (&block
, dest
, src
, add
, nelems
);
1257 return gfc_finish_block (&block
);
1260 /* Allocatable arrays in LINEAR clauses need to be allocated
1261 and copied from SRC. */
1262 gfc_add_modify (&block
, dest
, src
);
1263 if (GFC_DESCRIPTOR_TYPE_P (type
))
1265 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
1266 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
1267 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1269 gfc_conv_descriptor_lbound_get (dest
, rank
));
1270 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1271 size
, gfc_index_one_node
);
1272 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
1273 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1274 gfc_array_index_type
, size
,
1275 gfc_conv_descriptor_stride_get (dest
, rank
));
1276 tree esize
= fold_convert (gfc_array_index_type
,
1277 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1278 nelems
= gfc_evaluate_now (unshare_expr (size
), &block
);
1279 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1280 nelems
, unshare_expr (esize
));
1281 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
1283 nelems
= fold_build2_loc (input_location
, MINUS_EXPR
,
1284 gfc_array_index_type
, nelems
,
1285 gfc_index_one_node
);
1288 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1289 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
1290 gfc_allocate_using_malloc (&block
, ptr
, size
, NULL_TREE
);
1291 if (GFC_DESCRIPTOR_TYPE_P (type
))
1293 gfc_conv_descriptor_data_set (&block
, unshare_expr (dest
), ptr
);
1294 tree etype
= gfc_get_element_type (type
);
1295 ptr
= fold_convert (build_pointer_type (etype
), ptr
);
1296 tree srcptr
= gfc_conv_descriptor_data_get (unshare_expr (src
));
1297 srcptr
= fold_convert (build_pointer_type (etype
), srcptr
);
1298 gfc_omp_linear_clause_add_loop (&block
, ptr
, srcptr
, add
, nelems
);
1302 gfc_add_modify (&block
, unshare_expr (dest
),
1303 fold_convert (TREE_TYPE (dest
), ptr
));
1304 ptr
= fold_convert (TREE_TYPE (dest
), ptr
);
1305 tree dstm
= build_fold_indirect_ref (ptr
);
1306 tree srcm
= build_fold_indirect_ref (unshare_expr (src
));
1307 gfc_add_modify (&block
, dstm
,
1308 fold_build2 (PLUS_EXPR
, TREE_TYPE (add
), srcm
, add
));
1310 return gfc_finish_block (&block
);
1313 /* Build and return code destructing DECL. Return NULL if nothing
1317 gfc_omp_clause_dtor (tree clause
, tree decl
)
1319 tree type
= TREE_TYPE (decl
), tem
;
1320 tree decl_type
= TREE_TYPE (OMP_CLAUSE_DECL (clause
));
1322 if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause
))
1323 && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause
))
1324 && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause
)))
1326 = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause
)));
1327 if (gfc_is_polymorphic_nonptr (decl_type
))
1329 if (POINTER_TYPE_P (decl_type
))
1330 decl_type
= TREE_TYPE (decl_type
);
1331 decl_type
= TREE_TYPE (TYPE_FIELDS (decl_type
));
1332 if (GFC_DESCRIPTOR_TYPE_P (decl_type
) || GFC_ARRAY_TYPE_P (decl_type
))
1333 fatal_error (input_location
,
1334 "Sorry, polymorphic arrays not yet supported for "
1336 stmtblock_t block
, cond_block
;
1337 gfc_start_block (&block
);
1338 gfc_init_block (&cond_block
);
1339 tree final
= gfc_class_vtab_final_get (decl
);
1340 tree size
= fold_convert (size_type_node
, gfc_class_vtab_size_get (decl
));
1342 gfc_init_se (&se
, NULL
);
1343 symbol_attribute attr
= {};
1344 tree data
= gfc_class_data_get (decl
);
1345 tree desc
= gfc_conv_scalar_to_descriptor (&se
, data
, attr
);
1347 /* Call class->_vpt->_finalize + free. */
1348 tree call
= build_fold_indirect_ref (final
);
1349 call
= build_call_expr_loc (input_location
, call
, 3,
1350 gfc_build_addr_expr (NULL
, desc
),
1351 size
, boolean_false_node
);
1352 gfc_add_block_to_block (&cond_block
, &se
.pre
);
1353 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
1354 gfc_add_block_to_block (&cond_block
, &se
.post
);
1355 /* Create: if (_vtab && _final) <cond_block> */
1356 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1357 gfc_class_vptr_get (decl
),
1359 tree cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1360 final
, null_pointer_node
);
1361 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1362 boolean_type_node
, cond
, cond2
);
1363 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1364 void_type_node
, cond
,
1365 gfc_finish_block (&cond_block
), NULL_TREE
));
1366 call
= builtin_decl_explicit (BUILT_IN_FREE
);
1367 call
= build_call_expr_loc (input_location
, call
, 1, data
);
1368 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
1369 return gfc_finish_block (&block
);
1372 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1373 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1374 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1375 || !POINTER_TYPE_P (type
)))
1377 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1378 return gfc_walk_alloc_comps (decl
, NULL_TREE
,
1379 OMP_CLAUSE_DECL (clause
),
1380 WALK_ALLOC_COMPS_DTOR
);
1384 if (GFC_DESCRIPTOR_TYPE_P (type
))
1386 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1387 to be deallocated if they were allocated. */
1388 tem
= gfc_conv_descriptor_data_get (decl
);
1389 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
1390 NULL_TREE
, true, NULL
,
1391 GFC_CAF_COARRAY_NOCOARRAY
);
1394 tem
= gfc_call_free (decl
);
1395 tem
= gfc_omp_unshare_expr (tem
);
1397 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1402 gfc_init_block (&block
);
1403 gfc_add_expr_to_block (&block
,
1404 gfc_walk_alloc_comps (decl
, NULL_TREE
,
1405 OMP_CLAUSE_DECL (clause
),
1406 WALK_ALLOC_COMPS_DTOR
));
1407 gfc_add_expr_to_block (&block
, tem
);
1408 then_b
= gfc_finish_block (&block
);
1410 tem
= fold_convert (pvoid_type_node
,
1411 GFC_DESCRIPTOR_TYPE_P (type
)
1412 ? gfc_conv_descriptor_data_get (decl
) : decl
);
1413 tem
= unshare_expr (tem
);
1414 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1415 tem
, null_pointer_node
);
1416 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1417 then_b
, build_empty_stmt (input_location
));
1422 /* Build a conditional expression in BLOCK. If COND_VAL is not
1423 null, then the block THEN_B is executed, otherwise ELSE_VAL
1424 is assigned to VAL. */
1427 gfc_build_cond_assign (stmtblock_t
*block
, tree val
, tree cond_val
,
1428 tree then_b
, tree else_val
)
1430 stmtblock_t cond_block
;
1431 tree else_b
= NULL_TREE
;
1432 tree val_ty
= TREE_TYPE (val
);
1436 gfc_init_block (&cond_block
);
1437 gfc_add_modify (&cond_block
, val
, fold_convert (val_ty
, else_val
));
1438 else_b
= gfc_finish_block (&cond_block
);
1440 gfc_add_expr_to_block (block
,
1441 build3_loc (input_location
, COND_EXPR
, void_type_node
,
1442 cond_val
, then_b
, else_b
));
1445 /* Build a conditional expression in BLOCK, returning a temporary
1446 variable containing the result. If COND_VAL is not null, then
1447 THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1452 gfc_build_cond_assign_expr (stmtblock_t
*block
, tree cond_val
,
1453 tree then_val
, tree else_val
)
1456 tree val_ty
= TREE_TYPE (then_val
);
1457 stmtblock_t cond_block
;
1459 val
= create_tmp_var (val_ty
);
1461 gfc_init_block (&cond_block
);
1462 gfc_add_modify (&cond_block
, val
, then_val
);
1463 tree then_b
= gfc_finish_block (&cond_block
);
1465 gfc_build_cond_assign (block
, val
, cond_val
, then_b
, else_val
);
1471 gfc_omp_finish_clause (tree c
, gimple_seq
*pre_p
, bool openacc
)
1473 if (OMP_CLAUSE_CODE (c
) != OMP_CLAUSE_MAP
)
1476 tree decl
= OMP_CLAUSE_DECL (c
);
1478 /* Assumed-size arrays can't be mapped implicitly, they have to be
1479 mapped explicitly using array sections. */
1480 if (TREE_CODE (decl
) == PARM_DECL
1481 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
1482 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
1483 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
1484 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
1487 error_at (OMP_CLAUSE_LOCATION (c
),
1488 "implicit mapping of assumed size array %qD", decl
);
1492 tree c2
= NULL_TREE
, c3
= NULL_TREE
, c4
= NULL_TREE
;
1493 tree present
= gfc_omp_check_optional_argument (decl
, true);
1494 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
1496 if (!gfc_omp_privatize_by_reference (decl
)
1497 && !GFC_DECL_GET_SCALAR_POINTER (decl
)
1498 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1499 && !GFC_DECL_CRAY_POINTEE (decl
)
1500 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
1502 tree orig_decl
= decl
;
1504 c4
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1505 OMP_CLAUSE_SET_MAP_KIND (c4
, GOMP_MAP_POINTER
);
1506 OMP_CLAUSE_DECL (c4
) = decl
;
1507 OMP_CLAUSE_SIZE (c4
) = size_int (0);
1508 decl
= build_fold_indirect_ref (decl
);
1510 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1511 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1513 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1514 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_POINTER
);
1515 OMP_CLAUSE_DECL (c2
) = decl
;
1516 OMP_CLAUSE_SIZE (c2
) = size_int (0);
1519 gfc_start_block (&block
);
1521 ptr
= gfc_build_cond_assign_expr (&block
, present
, decl
,
1523 gimplify_and_add (gfc_finish_block (&block
), pre_p
);
1524 ptr
= build_fold_indirect_ref (ptr
);
1525 OMP_CLAUSE_DECL (c
) = ptr
;
1526 OMP_CLAUSE_SIZE (c
) = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
1530 OMP_CLAUSE_DECL (c
) = decl
;
1531 OMP_CLAUSE_SIZE (c
) = NULL_TREE
;
1533 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1534 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1535 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1537 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1538 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1539 OMP_CLAUSE_DECL (c3
) = unshare_expr (decl
);
1540 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1541 decl
= build_fold_indirect_ref (decl
);
1542 OMP_CLAUSE_DECL (c
) = decl
;
1545 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1548 gfc_start_block (&block
);
1549 tree type
= TREE_TYPE (decl
);
1550 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1552 /* OpenMP: automatically map pointer targets with the pointer;
1553 hence, always update the descriptor/pointer itself.
1554 NOTE: This also remaps the pointer for allocatable arrays with
1555 'target' attribute which also don't have the 'restrict' qualifier. */
1556 bool always_modifier
= false;
1559 && !(TYPE_QUALS (TREE_TYPE (ptr
)) & TYPE_QUAL_RESTRICT
))
1560 always_modifier
= true;
1563 ptr
= gfc_build_cond_assign_expr (&block
, present
, ptr
,
1565 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
1566 ptr
= build_fold_indirect_ref (ptr
);
1567 OMP_CLAUSE_DECL (c
) = ptr
;
1568 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1569 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_TO_PSET
);
1572 ptr
= create_tmp_var (TREE_TYPE (TREE_OPERAND (decl
, 0)));
1573 gfc_add_modify (&block
, ptr
, TREE_OPERAND (decl
, 0));
1575 OMP_CLAUSE_DECL (c2
) = build_fold_indirect_ref (ptr
);
1578 OMP_CLAUSE_DECL (c2
) = decl
;
1579 OMP_CLAUSE_SIZE (c2
) = TYPE_SIZE_UNIT (type
);
1580 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1581 OMP_CLAUSE_SET_MAP_KIND (c3
, always_modifier
? GOMP_MAP_ALWAYS_POINTER
1582 : GOMP_MAP_POINTER
);
1585 ptr
= gfc_conv_descriptor_data_get (decl
);
1586 ptr
= gfc_build_addr_expr (NULL
, ptr
);
1587 ptr
= gfc_build_cond_assign_expr (&block
, present
,
1588 ptr
, null_pointer_node
);
1589 ptr
= build_fold_indirect_ref (ptr
);
1590 OMP_CLAUSE_DECL (c3
) = ptr
;
1593 OMP_CLAUSE_DECL (c3
) = gfc_conv_descriptor_data_get (decl
);
1594 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1595 tree size
= create_tmp_var (gfc_array_index_type
);
1596 tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
1597 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
1598 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
1599 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
1601 stmtblock_t cond_block
;
1602 tree tem
, then_b
, else_b
, zero
, cond
;
1604 gfc_init_block (&cond_block
);
1605 tem
= gfc_full_array_size (&cond_block
, decl
,
1606 GFC_TYPE_ARRAY_RANK (type
));
1607 gfc_add_modify (&cond_block
, size
, tem
);
1608 gfc_add_modify (&cond_block
, size
,
1609 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1611 then_b
= gfc_finish_block (&cond_block
);
1612 gfc_init_block (&cond_block
);
1613 zero
= build_int_cst (gfc_array_index_type
, 0);
1614 gfc_add_modify (&cond_block
, size
, zero
);
1615 else_b
= gfc_finish_block (&cond_block
);
1616 tem
= gfc_conv_descriptor_data_get (decl
);
1617 tem
= fold_convert (pvoid_type_node
, tem
);
1618 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1619 boolean_type_node
, tem
, null_pointer_node
);
1622 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1623 boolean_type_node
, present
, cond
);
1625 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1626 void_type_node
, cond
,
1631 stmtblock_t cond_block
;
1634 gfc_init_block (&cond_block
);
1635 gfc_add_modify (&cond_block
, size
,
1636 gfc_full_array_size (&cond_block
, decl
,
1637 GFC_TYPE_ARRAY_RANK (type
)));
1638 gfc_add_modify (&cond_block
, size
,
1639 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1641 then_b
= gfc_finish_block (&cond_block
);
1643 gfc_build_cond_assign (&block
, size
, present
, then_b
,
1644 build_int_cst (gfc_array_index_type
, 0));
1648 gfc_add_modify (&block
, size
,
1649 gfc_full_array_size (&block
, decl
,
1650 GFC_TYPE_ARRAY_RANK (type
)));
1651 gfc_add_modify (&block
, size
,
1652 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1655 OMP_CLAUSE_SIZE (c
) = size
;
1656 tree stmt
= gfc_finish_block (&block
);
1657 gimplify_and_add (stmt
, pre_p
);
1660 if (OMP_CLAUSE_SIZE (c
) == NULL_TREE
)
1662 = DECL_P (decl
) ? DECL_SIZE_UNIT (decl
)
1663 : TYPE_SIZE_UNIT (TREE_TYPE (decl
));
1664 if (gimplify_expr (&OMP_CLAUSE_SIZE (c
), pre_p
,
1665 NULL
, is_gimple_val
, fb_rvalue
) == GS_ERROR
)
1666 OMP_CLAUSE_SIZE (c
) = size_int (0);
1669 OMP_CLAUSE_CHAIN (c2
) = OMP_CLAUSE_CHAIN (last
);
1670 OMP_CLAUSE_CHAIN (last
) = c2
;
1675 OMP_CLAUSE_CHAIN (c3
) = OMP_CLAUSE_CHAIN (last
);
1676 OMP_CLAUSE_CHAIN (last
) = c3
;
1681 OMP_CLAUSE_CHAIN (c4
) = OMP_CLAUSE_CHAIN (last
);
1682 OMP_CLAUSE_CHAIN (last
) = c4
;
1687 /* Return true if DECL is a scalar variable (for the purpose of
1688 implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
1689 is true, allocatables and pointers are permitted. */
1692 gfc_omp_scalar_p (tree decl
, bool ptr_alloc_ok
)
1694 tree type
= TREE_TYPE (decl
);
1695 if (TREE_CODE (type
) == REFERENCE_TYPE
)
1696 type
= TREE_TYPE (type
);
1697 if (TREE_CODE (type
) == POINTER_TYPE
)
1699 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1700 || GFC_DECL_GET_SCALAR_POINTER (decl
))
1704 type
= TREE_TYPE (type
);
1706 if (GFC_ARRAY_TYPE_P (type
)
1707 || GFC_CLASS_TYPE_P (type
))
1710 if ((TREE_CODE (type
) == ARRAY_TYPE
|| TREE_CODE (type
) == INTEGER_TYPE
)
1711 && TYPE_STRING_FLAG (type
))
1713 if (INTEGRAL_TYPE_P (type
)
1714 || SCALAR_FLOAT_TYPE_P (type
)
1715 || COMPLEX_FLOAT_TYPE_P (type
))
1721 /* Return true if DECL is a scalar with target attribute but does not have the
1722 allocatable (or pointer) attribute (for the purpose of implicit mapping). */
1725 gfc_omp_scalar_target_p (tree decl
)
1727 return (DECL_P (decl
) && GFC_DECL_GET_SCALAR_TARGET (decl
)
1728 && gfc_omp_scalar_p (decl
, false));
1732 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1733 disregarded in OpenMP construct, because it is going to be
1734 remapped during OpenMP lowering. SHARED is true if DECL
1735 is going to be shared, false if it is going to be privatized. */
1738 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
1740 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1741 && DECL_HAS_VALUE_EXPR_P (decl
))
1743 tree value
= DECL_VALUE_EXPR (decl
);
1745 if (TREE_CODE (value
) == COMPONENT_REF
1746 && VAR_P (TREE_OPERAND (value
, 0))
1747 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1749 /* If variable in COMMON or EQUIVALENCE is privatized, return
1750 true, as just that variable is supposed to be privatized,
1751 not the whole COMMON or whole EQUIVALENCE.
1752 For shared variables in COMMON or EQUIVALENCE, let them be
1753 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1754 from the same COMMON or EQUIVALENCE just one sharing of the
1755 whole COMMON or EQUIVALENCE is enough. */
1760 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
1766 /* Return true if DECL that is shared iff SHARED is true should
1767 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1771 gfc_omp_private_debug_clause (tree decl
, bool shared
)
1773 if (GFC_DECL_CRAY_POINTEE (decl
))
1776 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1777 && DECL_HAS_VALUE_EXPR_P (decl
))
1779 tree value
= DECL_VALUE_EXPR (decl
);
1781 if (TREE_CODE (value
) == COMPONENT_REF
1782 && VAR_P (TREE_OPERAND (value
, 0))
1783 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1790 /* Register language specific type size variables as potentially OpenMP
1791 firstprivate variables. */
1794 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
1796 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
1800 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
1801 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
1803 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
1804 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
1805 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
1807 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
1808 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
1814 gfc_trans_add_clause (tree node
, tree tail
)
1816 OMP_CLAUSE_CHAIN (node
) = tail
;
1821 gfc_trans_omp_variable (gfc_symbol
*sym
, bool declare_simd
)
1826 gfc_symbol
*proc_sym
;
1827 gfc_formal_arglist
*f
;
1829 gcc_assert (sym
->attr
.dummy
);
1830 proc_sym
= sym
->ns
->proc_name
;
1831 if (proc_sym
->attr
.entry_master
)
1833 if (gfc_return_by_reference (proc_sym
))
1836 if (proc_sym
->ts
.type
== BT_CHARACTER
)
1839 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
1845 return build_int_cst (integer_type_node
, cnt
);
1848 tree t
= gfc_get_symbol_decl (sym
);
1852 bool alternate_entry
;
1855 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1856 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1857 && sym
->result
== sym
;
1858 entry_master
= sym
->attr
.result
1859 && sym
->ns
->proc_name
->attr
.entry_master
1860 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1861 parent_decl
= current_function_decl
1862 ? DECL_CONTEXT (current_function_decl
) : NULL_TREE
;
1864 if ((t
== parent_decl
&& return_value
)
1865 || (sym
->ns
&& sym
->ns
->proc_name
1866 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1867 && (alternate_entry
|| entry_master
)))
1872 /* Special case for assigning the return value of a function.
1873 Self recursive functions must have an explicit return value. */
1874 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
1875 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1877 /* Similarly for alternate entry points. */
1878 else if (alternate_entry
1879 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1882 gfc_entry_list
*el
= NULL
;
1884 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1887 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1892 else if (entry_master
1893 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1895 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1901 gfc_trans_omp_variable_list (enum omp_clause_code code
,
1902 gfc_omp_namelist
*namelist
, tree list
,
1905 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1906 if (namelist
->sym
->attr
.referenced
|| declare_simd
)
1908 tree t
= gfc_trans_omp_variable (namelist
->sym
, declare_simd
);
1909 if (t
!= error_mark_node
)
1911 tree node
= build_omp_clause (input_location
, code
);
1912 OMP_CLAUSE_DECL (node
) = t
;
1913 list
= gfc_trans_add_clause (node
, list
);
1915 if (code
== OMP_CLAUSE_LASTPRIVATE
1916 && namelist
->u
.lastprivate_conditional
)
1917 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node
) = 1;
1923 struct omp_udr_find_orig_data
1925 gfc_omp_udr
*omp_udr
;
1930 omp_udr_find_orig (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1933 struct omp_udr_find_orig_data
*cd
= (struct omp_udr_find_orig_data
*) data
;
1934 if ((*e
)->expr_type
== EXPR_VARIABLE
1935 && (*e
)->symtree
->n
.sym
== cd
->omp_udr
->omp_orig
)
1936 cd
->omp_orig_seen
= true;
1942 gfc_trans_omp_array_reduction_or_udr (tree c
, gfc_omp_namelist
*n
, locus where
)
1944 gfc_symbol
*sym
= n
->sym
;
1945 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
1946 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
1947 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
1948 gfc_symbol omp_var_copy
[4];
1949 gfc_expr
*e1
, *e2
, *e3
, *e4
;
1951 tree decl
, backend_decl
, stmt
, type
, outer_decl
;
1952 locus old_loc
= gfc_current_locus
;
1955 gfc_omp_udr
*udr
= n
->u2
.udr
? n
->u2
.udr
->udr
: NULL
;
1957 decl
= OMP_CLAUSE_DECL (c
);
1958 gfc_current_locus
= where
;
1959 type
= TREE_TYPE (decl
);
1960 outer_decl
= create_tmp_var_raw (type
);
1961 if (TREE_CODE (decl
) == PARM_DECL
1962 && TREE_CODE (type
) == REFERENCE_TYPE
1963 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
))
1964 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type
)) == GFC_ARRAY_ALLOCATABLE
)
1966 decl
= build_fold_indirect_ref (decl
);
1967 type
= TREE_TYPE (type
);
1970 /* Create a fake symbol for init value. */
1971 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
1972 init_val_sym
.ns
= sym
->ns
;
1973 init_val_sym
.name
= sym
->name
;
1974 init_val_sym
.ts
= sym
->ts
;
1975 init_val_sym
.attr
.referenced
= 1;
1976 init_val_sym
.declared_at
= where
;
1977 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
1978 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1979 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
1980 else if (udr
->initializer_ns
)
1981 backend_decl
= NULL
;
1983 switch (sym
->ts
.type
)
1989 backend_decl
= build_zero_cst (gfc_sym_type (&init_val_sym
));
1992 backend_decl
= NULL_TREE
;
1995 init_val_sym
.backend_decl
= backend_decl
;
1997 /* Create a fake symbol for the outer array reference. */
2000 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
2001 outer_sym
.attr
.dummy
= 0;
2002 outer_sym
.attr
.result
= 0;
2003 outer_sym
.attr
.flavor
= FL_VARIABLE
;
2004 outer_sym
.backend_decl
= outer_decl
;
2005 if (decl
!= OMP_CLAUSE_DECL (c
))
2006 outer_sym
.backend_decl
= build_fold_indirect_ref (outer_decl
);
2008 /* Create fake symtrees for it. */
2009 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
2010 symtree1
->n
.sym
= sym
;
2011 gcc_assert (symtree1
== root1
);
2013 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
2014 symtree2
->n
.sym
= &init_val_sym
;
2015 gcc_assert (symtree2
== root2
);
2017 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
2018 symtree3
->n
.sym
= &outer_sym
;
2019 gcc_assert (symtree3
== root3
);
2021 memset (omp_var_copy
, 0, sizeof omp_var_copy
);
2024 omp_var_copy
[0] = *udr
->omp_out
;
2025 omp_var_copy
[1] = *udr
->omp_in
;
2026 *udr
->omp_out
= outer_sym
;
2027 *udr
->omp_in
= *sym
;
2028 if (udr
->initializer_ns
)
2030 omp_var_copy
[2] = *udr
->omp_priv
;
2031 omp_var_copy
[3] = *udr
->omp_orig
;
2032 *udr
->omp_priv
= *sym
;
2033 *udr
->omp_orig
= outer_sym
;
2037 /* Create expressions. */
2038 e1
= gfc_get_expr ();
2039 e1
->expr_type
= EXPR_VARIABLE
;
2041 e1
->symtree
= symtree1
;
2043 if (sym
->attr
.dimension
)
2045 e1
->ref
= ref
= gfc_get_ref ();
2046 ref
->type
= REF_ARRAY
;
2047 ref
->u
.ar
.where
= where
;
2048 ref
->u
.ar
.as
= sym
->as
;
2049 ref
->u
.ar
.type
= AR_FULL
;
2050 ref
->u
.ar
.dimen
= 0;
2052 t
= gfc_resolve_expr (e1
);
2056 if (backend_decl
!= NULL_TREE
)
2058 e2
= gfc_get_expr ();
2059 e2
->expr_type
= EXPR_VARIABLE
;
2061 e2
->symtree
= symtree2
;
2063 t
= gfc_resolve_expr (e2
);
2066 else if (udr
->initializer_ns
== NULL
)
2068 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
2069 e2
= gfc_default_initializer (&sym
->ts
);
2071 t
= gfc_resolve_expr (e2
);
2074 else if (n
->u2
.udr
->initializer
->op
== EXEC_ASSIGN
)
2076 e2
= gfc_copy_expr (n
->u2
.udr
->initializer
->expr2
);
2077 t
= gfc_resolve_expr (e2
);
2080 if (udr
&& udr
->initializer_ns
)
2082 struct omp_udr_find_orig_data cd
;
2084 cd
.omp_orig_seen
= false;
2085 gfc_code_walker (&n
->u2
.udr
->initializer
,
2086 gfc_dummy_code_callback
, omp_udr_find_orig
, &cd
);
2087 if (cd
.omp_orig_seen
)
2088 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c
) = 1;
2091 e3
= gfc_copy_expr (e1
);
2092 e3
->symtree
= symtree3
;
2093 t
= gfc_resolve_expr (e3
);
2098 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
2102 e4
= gfc_add (e3
, e1
);
2105 e4
= gfc_multiply (e3
, e1
);
2107 case TRUTH_ANDIF_EXPR
:
2108 e4
= gfc_and (e3
, e1
);
2110 case TRUTH_ORIF_EXPR
:
2111 e4
= gfc_or (e3
, e1
);
2114 e4
= gfc_eqv (e3
, e1
);
2117 e4
= gfc_neqv (e3
, e1
);
2135 if (n
->u2
.udr
->combiner
->op
== EXEC_ASSIGN
)
2138 e3
= gfc_copy_expr (n
->u2
.udr
->combiner
->expr1
);
2139 e4
= gfc_copy_expr (n
->u2
.udr
->combiner
->expr2
);
2140 t
= gfc_resolve_expr (e3
);
2142 t
= gfc_resolve_expr (e4
);
2151 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
2152 intrinsic_sym
.ns
= sym
->ns
;
2153 intrinsic_sym
.name
= iname
;
2154 intrinsic_sym
.ts
= sym
->ts
;
2155 intrinsic_sym
.attr
.referenced
= 1;
2156 intrinsic_sym
.attr
.intrinsic
= 1;
2157 intrinsic_sym
.attr
.function
= 1;
2158 intrinsic_sym
.attr
.implicit_type
= 1;
2159 intrinsic_sym
.result
= &intrinsic_sym
;
2160 intrinsic_sym
.declared_at
= where
;
2162 symtree4
= gfc_new_symtree (&root4
, iname
);
2163 symtree4
->n
.sym
= &intrinsic_sym
;
2164 gcc_assert (symtree4
== root4
);
2166 e4
= gfc_get_expr ();
2167 e4
->expr_type
= EXPR_FUNCTION
;
2169 e4
->symtree
= symtree4
;
2170 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
2171 e4
->value
.function
.actual
->expr
= e3
;
2172 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
2173 e4
->value
.function
.actual
->next
->expr
= e1
;
2175 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
2177 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
2178 e1
= gfc_copy_expr (e1
);
2179 e3
= gfc_copy_expr (e3
);
2180 t
= gfc_resolve_expr (e4
);
2184 /* Create the init statement list. */
2187 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
2189 stmt
= gfc_trans_call (n
->u2
.udr
->initializer
, false,
2190 NULL_TREE
, NULL_TREE
, false);
2191 if (TREE_CODE (stmt
) != BIND_EXPR
)
2192 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
2195 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
2197 /* Create the merge statement list. */
2200 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
2202 stmt
= gfc_trans_call (n
->u2
.udr
->combiner
, false,
2203 NULL_TREE
, NULL_TREE
, false);
2204 if (TREE_CODE (stmt
) != BIND_EXPR
)
2205 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
2208 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
2210 /* And stick the placeholder VAR_DECL into the clause as well. */
2211 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_decl
;
2213 gfc_current_locus
= old_loc
;
2226 gfc_free_array_spec (outer_sym
.as
);
2230 *udr
->omp_out
= omp_var_copy
[0];
2231 *udr
->omp_in
= omp_var_copy
[1];
2232 if (udr
->initializer_ns
)
2234 *udr
->omp_priv
= omp_var_copy
[2];
2235 *udr
->omp_orig
= omp_var_copy
[3];
2241 gfc_trans_omp_reduction_list (int kind
, gfc_omp_namelist
*namelist
, tree list
,
2242 locus where
, bool mark_addressable
)
2244 omp_clause_code clause
= OMP_CLAUSE_REDUCTION
;
2247 case OMP_LIST_REDUCTION
:
2248 case OMP_LIST_REDUCTION_INSCAN
:
2249 case OMP_LIST_REDUCTION_TASK
:
2251 case OMP_LIST_IN_REDUCTION
:
2252 clause
= OMP_CLAUSE_IN_REDUCTION
;
2254 case OMP_LIST_TASK_REDUCTION
:
2255 clause
= OMP_CLAUSE_TASK_REDUCTION
;
2260 for (; namelist
!= NULL
; namelist
= namelist
->next
)
2261 if (namelist
->sym
->attr
.referenced
)
2263 tree t
= gfc_trans_omp_variable (namelist
->sym
, false);
2264 if (t
!= error_mark_node
)
2266 tree node
= build_omp_clause (gfc_get_location (&namelist
->where
),
2268 OMP_CLAUSE_DECL (node
) = t
;
2269 if (mark_addressable
)
2270 TREE_ADDRESSABLE (t
) = 1;
2271 if (kind
== OMP_LIST_REDUCTION_INSCAN
)
2272 OMP_CLAUSE_REDUCTION_INSCAN (node
) = 1;
2273 if (kind
== OMP_LIST_REDUCTION_TASK
)
2274 OMP_CLAUSE_REDUCTION_TASK (node
) = 1;
2275 switch (namelist
->u
.reduction_op
)
2277 case OMP_REDUCTION_PLUS
:
2278 OMP_CLAUSE_REDUCTION_CODE (node
) = PLUS_EXPR
;
2280 case OMP_REDUCTION_MINUS
:
2281 OMP_CLAUSE_REDUCTION_CODE (node
) = MINUS_EXPR
;
2283 case OMP_REDUCTION_TIMES
:
2284 OMP_CLAUSE_REDUCTION_CODE (node
) = MULT_EXPR
;
2286 case OMP_REDUCTION_AND
:
2287 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ANDIF_EXPR
;
2289 case OMP_REDUCTION_OR
:
2290 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ORIF_EXPR
;
2292 case OMP_REDUCTION_EQV
:
2293 OMP_CLAUSE_REDUCTION_CODE (node
) = EQ_EXPR
;
2295 case OMP_REDUCTION_NEQV
:
2296 OMP_CLAUSE_REDUCTION_CODE (node
) = NE_EXPR
;
2298 case OMP_REDUCTION_MAX
:
2299 OMP_CLAUSE_REDUCTION_CODE (node
) = MAX_EXPR
;
2301 case OMP_REDUCTION_MIN
:
2302 OMP_CLAUSE_REDUCTION_CODE (node
) = MIN_EXPR
;
2304 case OMP_REDUCTION_IAND
:
2305 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_AND_EXPR
;
2307 case OMP_REDUCTION_IOR
:
2308 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_IOR_EXPR
;
2310 case OMP_REDUCTION_IEOR
:
2311 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_XOR_EXPR
;
2313 case OMP_REDUCTION_USER
:
2314 OMP_CLAUSE_REDUCTION_CODE (node
) = ERROR_MARK
;
2319 if (namelist
->sym
->attr
.dimension
2320 || namelist
->u
.reduction_op
== OMP_REDUCTION_USER
2321 || namelist
->sym
->attr
.allocatable
)
2322 gfc_trans_omp_array_reduction_or_udr (node
, namelist
, where
);
2323 list
= gfc_trans_add_clause (node
, list
);
2330 gfc_convert_expr_to_tree (stmtblock_t
*block
, gfc_expr
*expr
)
2335 gfc_init_se (&se
, NULL
);
2336 gfc_conv_expr (&se
, expr
);
2337 gfc_add_block_to_block (block
, &se
.pre
);
2338 result
= gfc_evaluate_now (se
.expr
, block
);
2339 gfc_add_block_to_block (block
, &se
.post
);
2344 static vec
<tree
, va_heap
, vl_embed
> *doacross_steps
;
2347 /* Translate an array section or array element. */
2350 gfc_trans_omp_array_section (stmtblock_t
*block
, gfc_omp_namelist
*n
,
2351 tree decl
, bool element
, gomp_map_kind ptr_kind
,
2352 tree
&node
, tree
&node2
, tree
&node3
, tree
&node4
)
2356 tree elemsz
= NULL_TREE
;
2358 gfc_init_se (&se
, NULL
);
2362 gfc_conv_expr_reference (&se
, n
->expr
);
2363 gfc_add_block_to_block (block
, &se
.pre
);
2365 OMP_CLAUSE_SIZE (node
) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr
)));
2366 elemsz
= OMP_CLAUSE_SIZE (node
);
2370 gfc_conv_expr_descriptor (&se
, n
->expr
);
2371 ptr
= gfc_conv_array_data (se
.expr
);
2372 tree type
= TREE_TYPE (se
.expr
);
2373 gfc_add_block_to_block (block
, &se
.pre
);
2374 OMP_CLAUSE_SIZE (node
) = gfc_full_array_size (block
, se
.expr
,
2375 GFC_TYPE_ARRAY_RANK (type
));
2376 elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2377 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2378 OMP_CLAUSE_SIZE (node
) = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2379 OMP_CLAUSE_SIZE (node
), elemsz
);
2381 gcc_assert (se
.post
.head
== NULL_TREE
);
2382 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
2383 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2384 ptr
= fold_convert (ptrdiff_type_node
, ptr
);
2386 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2387 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
2388 && ptr_kind
== GOMP_MAP_POINTER
)
2390 node4
= build_omp_clause (input_location
,
2392 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2393 OMP_CLAUSE_DECL (node4
) = decl
;
2394 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2395 decl
= build_fold_indirect_ref (decl
);
2397 else if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
2398 && n
->expr
->ts
.type
== BT_CHARACTER
2399 && n
->expr
->ts
.deferred
)
2401 gomp_map_kind map_kind
;
2402 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
2403 map_kind
= GOMP_MAP_TO
;
2404 else if (OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_RELEASE
2405 || OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_DELETE
)
2406 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
2408 map_kind
= GOMP_MAP_ALLOC
;
2409 gcc_assert (se
.string_length
);
2410 node4
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2411 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
2412 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
2413 OMP_CLAUSE_SIZE (node4
) = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
2415 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2418 tree type
= TREE_TYPE (decl
);
2419 ptr2
= gfc_conv_descriptor_data_get (decl
);
2420 desc_node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2421 OMP_CLAUSE_DECL (desc_node
) = decl
;
2422 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
2423 if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
)
2425 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO
);
2427 node
= desc_node
; /* Needs to come first. */
2431 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO_PSET
);
2434 node3
= build_omp_clause (input_location
,
2436 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2437 OMP_CLAUSE_DECL (node3
)
2438 = gfc_conv_descriptor_data_get (decl
);
2439 /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
2440 cast prevents gimplify.c from recognising it as being part of the
2441 struct – and adding an 'alloc: for the 'desc.data' pointer, which
2442 would break as the 'desc' (the descriptor) is also mapped
2443 (see node4 above). */
2444 if (ptr_kind
== GOMP_MAP_ATTACH_DETACH
)
2445 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
2449 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
)
2452 ptr2
= build_fold_addr_expr (decl
);
2453 offset
= fold_build2 (MINUS_EXPR
, ptrdiff_type_node
, ptr
,
2454 fold_convert (ptrdiff_type_node
, ptr2
));
2455 offset
= build2 (TRUNC_DIV_EXPR
, ptrdiff_type_node
,
2456 offset
, fold_convert (ptrdiff_type_node
, elemsz
));
2457 offset
= build4_loc (input_location
, ARRAY_REF
,
2458 TREE_TYPE (TREE_TYPE (decl
)),
2459 decl
, offset
, NULL_TREE
, NULL_TREE
);
2460 OMP_CLAUSE_DECL (node
) = offset
;
2464 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl
)));
2467 node3
= build_omp_clause (input_location
,
2469 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2470 OMP_CLAUSE_DECL (node3
) = decl
;
2472 ptr2
= fold_convert (ptrdiff_type_node
, ptr2
);
2473 OMP_CLAUSE_SIZE (node3
) = fold_build2 (MINUS_EXPR
, ptrdiff_type_node
,
2478 handle_iterator (gfc_namespace
*ns
, stmtblock_t
*iter_block
, tree block
)
2480 tree list
= NULL_TREE
;
2481 for (gfc_symbol
*sym
= ns
->proc_name
; sym
; sym
= sym
->tlink
)
2486 tree last
= make_tree_vec (6);
2487 tree iter_var
= gfc_get_symbol_decl (sym
);
2488 tree type
= TREE_TYPE (iter_var
);
2489 TREE_VEC_ELT (last
, 0) = iter_var
;
2490 DECL_CHAIN (iter_var
) = BLOCK_VARS (block
);
2491 BLOCK_VARS (block
) = iter_var
;
2494 c
= gfc_constructor_first (sym
->value
->value
.constructor
);
2495 gfc_init_se (&se
, NULL
);
2496 gfc_conv_expr (&se
, c
->expr
);
2497 gfc_add_block_to_block (iter_block
, &se
.pre
);
2498 gfc_add_block_to_block (iter_block
, &se
.post
);
2499 TREE_VEC_ELT (last
, 1) = fold_convert (type
,
2500 gfc_evaluate_now (se
.expr
,
2503 c
= gfc_constructor_next (c
);
2504 gfc_init_se (&se
, NULL
);
2505 gfc_conv_expr (&se
, c
->expr
);
2506 gfc_add_block_to_block (iter_block
, &se
.pre
);
2507 gfc_add_block_to_block (iter_block
, &se
.post
);
2508 TREE_VEC_ELT (last
, 2) = fold_convert (type
,
2509 gfc_evaluate_now (se
.expr
,
2512 c
= gfc_constructor_next (c
);
2516 gfc_init_se (&se
, NULL
);
2517 gfc_conv_expr (&se
, c
->expr
);
2518 gfc_add_block_to_block (iter_block
, &se
.pre
);
2519 gfc_add_block_to_block (iter_block
, &se
.post
);
2520 gfc_conv_expr (&se
, c
->expr
);
2521 step
= fold_convert (type
,
2522 gfc_evaluate_now (se
.expr
,
2526 step
= build_int_cst (type
, 1);
2527 TREE_VEC_ELT (last
, 3) = step
;
2529 TREE_VEC_ELT (last
, 4) = save_expr (step
);
2530 TREE_CHAIN (last
) = list
;
2537 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
2538 locus where
, bool declare_simd
= false,
2539 bool openacc
= false)
2541 tree omp_clauses
= NULL_TREE
, prev_clauses
, chunk_size
, c
;
2542 tree iterator
= NULL_TREE
;
2543 tree tree_block
= NULL_TREE
;
2544 stmtblock_t iter_block
;
2546 enum omp_clause_code clause_code
;
2547 gfc_omp_namelist
*prev
= NULL
;
2550 if (clauses
== NULL
)
2553 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
2555 gfc_omp_namelist
*n
= clauses
->lists
[list
];
2561 case OMP_LIST_REDUCTION
:
2562 case OMP_LIST_REDUCTION_INSCAN
:
2563 case OMP_LIST_REDUCTION_TASK
:
2564 case OMP_LIST_IN_REDUCTION
:
2565 case OMP_LIST_TASK_REDUCTION
:
2566 /* An OpenACC async clause indicates the need to set reduction
2567 arguments addressable, to allow asynchronous copy-out. */
2568 omp_clauses
= gfc_trans_omp_reduction_list (list
, n
, omp_clauses
,
2569 where
, clauses
->async
);
2571 case OMP_LIST_PRIVATE
:
2572 clause_code
= OMP_CLAUSE_PRIVATE
;
2574 case OMP_LIST_SHARED
:
2575 clause_code
= OMP_CLAUSE_SHARED
;
2577 case OMP_LIST_FIRSTPRIVATE
:
2578 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
2580 case OMP_LIST_LASTPRIVATE
:
2581 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
2583 case OMP_LIST_COPYIN
:
2584 clause_code
= OMP_CLAUSE_COPYIN
;
2586 case OMP_LIST_COPYPRIVATE
:
2587 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
2589 case OMP_LIST_UNIFORM
:
2590 clause_code
= OMP_CLAUSE_UNIFORM
;
2592 case OMP_LIST_USE_DEVICE
:
2593 case OMP_LIST_USE_DEVICE_PTR
:
2594 clause_code
= OMP_CLAUSE_USE_DEVICE_PTR
;
2596 case OMP_LIST_USE_DEVICE_ADDR
:
2597 clause_code
= OMP_CLAUSE_USE_DEVICE_ADDR
;
2599 case OMP_LIST_IS_DEVICE_PTR
:
2600 clause_code
= OMP_CLAUSE_IS_DEVICE_PTR
;
2602 case OMP_LIST_NONTEMPORAL
:
2603 clause_code
= OMP_CLAUSE_NONTEMPORAL
;
2605 case OMP_LIST_SCAN_IN
:
2606 clause_code
= OMP_CLAUSE_INCLUSIVE
;
2608 case OMP_LIST_SCAN_EX
:
2609 clause_code
= OMP_CLAUSE_EXCLUSIVE
;
2614 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
,
2617 case OMP_LIST_ALIGNED
:
2618 for (; n
!= NULL
; n
= n
->next
)
2619 if (n
->sym
->attr
.referenced
|| declare_simd
)
2621 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2622 if (t
!= error_mark_node
)
2624 tree node
= build_omp_clause (input_location
,
2625 OMP_CLAUSE_ALIGNED
);
2626 OMP_CLAUSE_DECL (node
) = t
;
2632 alignment_var
= gfc_conv_constant_to_tree (n
->expr
);
2635 gfc_init_se (&se
, NULL
);
2636 gfc_conv_expr (&se
, n
->expr
);
2637 gfc_add_block_to_block (block
, &se
.pre
);
2638 alignment_var
= gfc_evaluate_now (se
.expr
, block
);
2639 gfc_add_block_to_block (block
, &se
.post
);
2641 OMP_CLAUSE_ALIGNED_ALIGNMENT (node
) = alignment_var
;
2643 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2647 case OMP_LIST_LINEAR
:
2649 gfc_expr
*last_step_expr
= NULL
;
2650 tree last_step
= NULL_TREE
;
2651 bool last_step_parm
= false;
2653 for (; n
!= NULL
; n
= n
->next
)
2657 last_step_expr
= n
->expr
;
2658 last_step
= NULL_TREE
;
2659 last_step_parm
= false;
2661 if (n
->sym
->attr
.referenced
|| declare_simd
)
2663 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2664 if (t
!= error_mark_node
)
2666 tree node
= build_omp_clause (input_location
,
2668 OMP_CLAUSE_DECL (node
) = t
;
2669 omp_clause_linear_kind kind
;
2670 switch (n
->u
.linear_op
)
2672 case OMP_LINEAR_DEFAULT
:
2673 kind
= OMP_CLAUSE_LINEAR_DEFAULT
;
2675 case OMP_LINEAR_REF
:
2676 kind
= OMP_CLAUSE_LINEAR_REF
;
2678 case OMP_LINEAR_VAL
:
2679 kind
= OMP_CLAUSE_LINEAR_VAL
;
2681 case OMP_LINEAR_UVAL
:
2682 kind
= OMP_CLAUSE_LINEAR_UVAL
;
2687 OMP_CLAUSE_LINEAR_KIND (node
) = kind
;
2688 if (last_step_expr
&& last_step
== NULL_TREE
)
2692 gfc_init_se (&se
, NULL
);
2693 gfc_conv_expr (&se
, last_step_expr
);
2694 gfc_add_block_to_block (block
, &se
.pre
);
2695 last_step
= gfc_evaluate_now (se
.expr
, block
);
2696 gfc_add_block_to_block (block
, &se
.post
);
2698 else if (last_step_expr
->expr_type
== EXPR_VARIABLE
)
2700 gfc_symbol
*s
= last_step_expr
->symtree
->n
.sym
;
2701 last_step
= gfc_trans_omp_variable (s
, true);
2702 last_step_parm
= true;
2706 = gfc_conv_constant_to_tree (last_step_expr
);
2710 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node
) = 1;
2711 OMP_CLAUSE_LINEAR_STEP (node
) = last_step
;
2715 if (kind
== OMP_CLAUSE_LINEAR_REF
)
2718 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
)
2720 type
= gfc_get_function_type (n
->sym
);
2721 type
= build_pointer_type (type
);
2724 type
= gfc_sym_type (n
->sym
);
2725 if (POINTER_TYPE_P (type
))
2726 type
= TREE_TYPE (type
);
2727 /* Otherwise to be determined what exactly
2729 tree t
= fold_convert (sizetype
, last_step
);
2730 t
= size_binop (MULT_EXPR
, t
,
2731 TYPE_SIZE_UNIT (type
));
2732 OMP_CLAUSE_LINEAR_STEP (node
) = t
;
2737 = gfc_typenode_for_spec (&n
->sym
->ts
);
2738 OMP_CLAUSE_LINEAR_STEP (node
)
2739 = fold_convert (type
, last_step
);
2742 if (n
->sym
->attr
.dimension
|| n
->sym
->attr
.allocatable
)
2743 OMP_CLAUSE_LINEAR_ARRAY (node
) = 1;
2744 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2750 case OMP_LIST_AFFINITY
:
2751 case OMP_LIST_DEPEND
:
2752 iterator
= NULL_TREE
;
2754 prev_clauses
= omp_clauses
;
2755 for (; n
!= NULL
; n
= n
->next
)
2757 if (iterator
&& prev
->u2
.ns
!= n
->u2
.ns
)
2759 BLOCK_SUBBLOCKS (tree_block
) = gfc_finish_block (&iter_block
);
2760 TREE_VEC_ELT (iterator
, 5) = tree_block
;
2761 for (tree c
= omp_clauses
; c
!= prev_clauses
;
2762 c
= OMP_CLAUSE_CHAIN (c
))
2763 OMP_CLAUSE_DECL (c
) = build_tree_list (iterator
,
2764 OMP_CLAUSE_DECL (c
));
2765 prev_clauses
= omp_clauses
;
2766 iterator
= NULL_TREE
;
2768 if (n
->u2
.ns
&& (!prev
|| prev
->u2
.ns
!= n
->u2
.ns
))
2770 gfc_init_block (&iter_block
);
2771 tree_block
= make_node (BLOCK
);
2772 TREE_USED (tree_block
) = 1;
2773 BLOCK_VARS (tree_block
) = NULL_TREE
;
2774 iterator
= handle_iterator (n
->u2
.ns
, block
,
2778 gfc_init_block (&iter_block
);
2780 if (list
== OMP_LIST_DEPEND
2781 && n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
)
2783 tree vec
= NULL_TREE
;
2787 tree addend
= integer_zero_node
, t
;
2791 addend
= gfc_conv_constant_to_tree (n
->expr
);
2792 if (TREE_CODE (addend
) == INTEGER_CST
2793 && tree_int_cst_sgn (addend
) == -1)
2796 addend
= const_unop (NEGATE_EXPR
,
2797 TREE_TYPE (addend
), addend
);
2800 t
= gfc_trans_omp_variable (n
->sym
, false);
2801 if (t
!= error_mark_node
)
2803 if (i
< vec_safe_length (doacross_steps
)
2804 && !integer_zerop (addend
)
2805 && (*doacross_steps
)[i
])
2807 tree step
= (*doacross_steps
)[i
];
2808 addend
= fold_convert (TREE_TYPE (step
), addend
);
2809 addend
= build2 (TRUNC_DIV_EXPR
,
2810 TREE_TYPE (step
), addend
, step
);
2812 vec
= tree_cons (addend
, t
, vec
);
2814 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec
) = 1;
2817 || n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
2821 if (vec
== NULL_TREE
)
2824 tree node
= build_omp_clause (input_location
,
2826 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_SINK
;
2827 OMP_CLAUSE_DECL (node
) = nreverse (vec
);
2828 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2832 if (!n
->sym
->attr
.referenced
)
2835 tree node
= build_omp_clause (input_location
,
2836 list
== OMP_LIST_DEPEND
2838 : OMP_CLAUSE_AFFINITY
);
2839 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2841 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2842 if (gfc_omp_privatize_by_reference (decl
))
2843 decl
= build_fold_indirect_ref (decl
);
2844 if (n
->u
.depend_op
== OMP_DEPEND_DEPOBJ
2845 && POINTER_TYPE_P (TREE_TYPE (decl
)))
2846 decl
= build_fold_indirect_ref (decl
);
2847 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2849 decl
= gfc_conv_descriptor_data_get (decl
);
2850 decl
= fold_convert (build_pointer_type (char_type_node
),
2852 decl
= build_fold_indirect_ref (decl
);
2854 else if (DECL_P (decl
))
2855 TREE_ADDRESSABLE (decl
) = 1;
2856 OMP_CLAUSE_DECL (node
) = decl
;
2861 gfc_init_se (&se
, NULL
);
2862 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2864 gfc_conv_expr_reference (&se
, n
->expr
);
2869 gfc_conv_expr_descriptor (&se
, n
->expr
);
2870 ptr
= gfc_conv_array_data (se
.expr
);
2872 gfc_add_block_to_block (&iter_block
, &se
.pre
);
2873 gfc_add_block_to_block (&iter_block
, &se
.post
);
2874 ptr
= fold_convert (build_pointer_type (char_type_node
),
2876 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2878 if (list
== OMP_LIST_DEPEND
)
2879 switch (n
->u
.depend_op
)
2882 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_IN
;
2884 case OMP_DEPEND_OUT
:
2885 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_OUT
;
2887 case OMP_DEPEND_INOUT
:
2888 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_INOUT
;
2890 case OMP_DEPEND_MUTEXINOUTSET
:
2891 OMP_CLAUSE_DEPEND_KIND (node
)
2892 = OMP_CLAUSE_DEPEND_MUTEXINOUTSET
;
2894 case OMP_DEPEND_DEPOBJ
:
2895 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_DEPOBJ
;
2901 gfc_add_block_to_block (block
, &iter_block
);
2902 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2906 BLOCK_SUBBLOCKS (tree_block
) = gfc_finish_block (&iter_block
);
2907 TREE_VEC_ELT (iterator
, 5) = tree_block
;
2908 for (tree c
= omp_clauses
; c
!= prev_clauses
;
2909 c
= OMP_CLAUSE_CHAIN (c
))
2910 OMP_CLAUSE_DECL (c
) = build_tree_list (iterator
,
2911 OMP_CLAUSE_DECL (c
));
2915 for (; n
!= NULL
; n
= n
->next
)
2917 if (!n
->sym
->attr
.referenced
)
2920 bool always_modifier
= false;
2921 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2922 tree node2
= NULL_TREE
;
2923 tree node3
= NULL_TREE
;
2924 tree node4
= NULL_TREE
;
2926 /* OpenMP: automatically map pointer targets with the pointer;
2927 hence, always update the descriptor/pointer itself. */
2929 && ((n
->expr
== NULL
&& n
->sym
->attr
.pointer
)
2930 || (n
->expr
&& gfc_expr_attr (n
->expr
).pointer
)))
2931 always_modifier
= true;
2933 switch (n
->u
.map_op
)
2936 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALLOC
);
2938 case OMP_MAP_IF_PRESENT
:
2939 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_IF_PRESENT
);
2941 case OMP_MAP_ATTACH
:
2942 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ATTACH
);
2945 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TO
);
2948 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FROM
);
2950 case OMP_MAP_TOFROM
:
2951 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TOFROM
);
2953 case OMP_MAP_ALWAYS_TO
:
2954 always_modifier
= true;
2955 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TO
);
2957 case OMP_MAP_ALWAYS_FROM
:
2958 always_modifier
= true;
2959 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_FROM
);
2961 case OMP_MAP_ALWAYS_TOFROM
:
2962 always_modifier
= true;
2963 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TOFROM
);
2965 case OMP_MAP_RELEASE
:
2966 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_RELEASE
);
2968 case OMP_MAP_DELETE
:
2969 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DELETE
);
2971 case OMP_MAP_DETACH
:
2972 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DETACH
);
2974 case OMP_MAP_FORCE_ALLOC
:
2975 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_ALLOC
);
2977 case OMP_MAP_FORCE_TO
:
2978 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TO
);
2980 case OMP_MAP_FORCE_FROM
:
2981 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_FROM
);
2983 case OMP_MAP_FORCE_TOFROM
:
2984 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TOFROM
);
2986 case OMP_MAP_FORCE_PRESENT
:
2987 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_PRESENT
);
2989 case OMP_MAP_FORCE_DEVICEPTR
:
2990 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_DEVICEPTR
);
2996 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2998 TREE_ADDRESSABLE (decl
) = 1;
3000 gfc_ref
*lastref
= NULL
;
3003 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
3004 if (ref
->type
== REF_COMPONENT
|| ref
->type
== REF_ARRAY
)
3007 bool allocatable
= false, pointer
= false;
3009 if (lastref
&& lastref
->type
== REF_COMPONENT
)
3011 gfc_component
*c
= lastref
->u
.c
.component
;
3013 if (c
->ts
.type
== BT_CLASS
)
3015 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
3016 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
3020 pointer
= c
->attr
.pointer
;
3021 allocatable
= c
->attr
.allocatable
;
3026 || (n
->expr
->ref
->type
== REF_ARRAY
3027 && n
->expr
->ref
->u
.ar
.type
== AR_FULL
))
3029 tree present
= gfc_omp_check_optional_argument (decl
, true);
3030 if (openacc
&& n
->sym
->ts
.type
== BT_CLASS
)
3032 tree type
= TREE_TYPE (decl
);
3033 if (n
->sym
->attr
.optional
)
3034 sorry ("optional class parameter");
3035 if (POINTER_TYPE_P (type
))
3037 node4
= build_omp_clause (input_location
,
3039 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
3040 OMP_CLAUSE_DECL (node4
) = decl
;
3041 OMP_CLAUSE_SIZE (node4
) = size_int (0);
3042 decl
= build_fold_indirect_ref (decl
);
3044 tree ptr
= gfc_class_data_get (decl
);
3045 ptr
= build_fold_indirect_ref (ptr
);
3046 OMP_CLAUSE_DECL (node
) = ptr
;
3047 OMP_CLAUSE_SIZE (node
) = gfc_class_vtab_size_get (decl
);
3048 node2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
3049 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
3050 OMP_CLAUSE_DECL (node2
) = decl
;
3051 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
3052 node3
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
3053 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH_DETACH
);
3054 OMP_CLAUSE_DECL (node3
) = gfc_class_data_get (decl
);
3055 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3056 goto finalize_map_clause
;
3058 else if (POINTER_TYPE_P (TREE_TYPE (decl
))
3059 && (gfc_omp_privatize_by_reference (decl
)
3060 || GFC_DECL_GET_SCALAR_POINTER (decl
)
3061 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
3062 || GFC_DECL_CRAY_POINTEE (decl
)
3063 || GFC_DESCRIPTOR_TYPE_P
3064 (TREE_TYPE (TREE_TYPE (decl
)))
3065 || n
->sym
->ts
.type
== BT_DERIVED
))
3067 tree orig_decl
= decl
;
3069 /* For nonallocatable, nonpointer arrays, a temporary
3070 variable is generated, but this one is only defined if
3071 the variable is present; hence, we now set it to NULL
3072 to avoid accessing undefined variables. We cannot use
3073 a temporary variable here as otherwise the replacement
3074 of the variables in omp-low.c will not work. */
3075 if (present
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)))
3077 tree tmp
= fold_build2_loc (input_location
,
3079 void_type_node
, decl
,
3081 tree cond
= fold_build1_loc (input_location
,
3085 gfc_add_expr_to_block (block
,
3086 build3_loc (input_location
,
3092 node4
= build_omp_clause (input_location
,
3094 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
3095 OMP_CLAUSE_DECL (node4
) = decl
;
3096 OMP_CLAUSE_SIZE (node4
) = size_int (0);
3097 decl
= build_fold_indirect_ref (decl
);
3098 if ((TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
3099 || gfc_omp_is_optional_argument (orig_decl
))
3100 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
3101 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
3103 node3
= build_omp_clause (input_location
,
3105 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
3106 OMP_CLAUSE_DECL (node3
) = decl
;
3107 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3108 decl
= build_fold_indirect_ref (decl
);
3111 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
3113 tree type
= TREE_TYPE (decl
);
3114 tree ptr
= gfc_conv_descriptor_data_get (decl
);
3116 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
3118 ptr
= fold_convert (build_pointer_type (char_type_node
),
3120 ptr
= build_fold_indirect_ref (ptr
);
3121 OMP_CLAUSE_DECL (node
) = ptr
;
3122 node2
= build_omp_clause (input_location
,
3124 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
3125 OMP_CLAUSE_DECL (node2
) = decl
;
3126 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
3127 node3
= build_omp_clause (input_location
,
3131 ptr
= gfc_conv_descriptor_data_get (decl
);
3132 ptr
= gfc_build_addr_expr (NULL
, ptr
);
3133 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
3135 ptr
= build_fold_indirect_ref (ptr
);
3136 OMP_CLAUSE_DECL (node3
) = ptr
;
3139 OMP_CLAUSE_DECL (node3
)
3140 = gfc_conv_descriptor_data_get (decl
);
3141 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3142 if (n
->u
.map_op
== OMP_MAP_ATTACH
)
3144 /* Standalone attach clauses used with arrays with
3145 descriptors must copy the descriptor to the target,
3146 else they won't have anything to perform the
3147 attachment onto (see OpenACC 2.6, "2.6.3. Data
3148 Structures with Pointers"). */
3149 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH
);
3150 /* We don't want to map PTR at all in this case, so
3151 delete its node and shuffle the others down. */
3155 goto finalize_map_clause
;
3157 else if (n
->u
.map_op
== OMP_MAP_DETACH
)
3159 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_DETACH
);
3160 /* Similarly to above, we don't want to unmap PTR
3165 goto finalize_map_clause
;
3168 OMP_CLAUSE_SET_MAP_KIND (node3
,
3170 ? GOMP_MAP_ALWAYS_POINTER
3171 : GOMP_MAP_POINTER
);
3173 /* We have to check for n->sym->attr.dimension because
3174 of scalar coarrays. */
3175 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.dimension
)
3177 stmtblock_t cond_block
;
3179 = gfc_create_var (gfc_array_index_type
, NULL
);
3180 tree tem
, then_b
, else_b
, zero
, cond
;
3182 gfc_init_block (&cond_block
);
3184 = gfc_full_array_size (&cond_block
, decl
,
3185 GFC_TYPE_ARRAY_RANK (type
));
3186 gfc_add_modify (&cond_block
, size
, tem
);
3187 then_b
= gfc_finish_block (&cond_block
);
3188 gfc_init_block (&cond_block
);
3189 zero
= build_int_cst (gfc_array_index_type
, 0);
3190 gfc_add_modify (&cond_block
, size
, zero
);
3191 else_b
= gfc_finish_block (&cond_block
);
3192 tem
= gfc_conv_descriptor_data_get (decl
);
3193 tem
= fold_convert (pvoid_type_node
, tem
);
3194 cond
= fold_build2_loc (input_location
, NE_EXPR
,
3196 tem
, null_pointer_node
);
3198 cond
= fold_build2_loc (input_location
,
3202 gfc_add_expr_to_block (block
,
3203 build3_loc (input_location
,
3208 OMP_CLAUSE_SIZE (node
) = size
;
3210 else if (n
->sym
->attr
.dimension
)
3212 stmtblock_t cond_block
;
3213 gfc_init_block (&cond_block
);
3214 tree size
= gfc_full_array_size (&cond_block
, decl
,
3215 GFC_TYPE_ARRAY_RANK (type
));
3218 tree var
= gfc_create_var (gfc_array_index_type
,
3220 gfc_add_modify (&cond_block
, var
, size
);
3221 tree cond_body
= gfc_finish_block (&cond_block
);
3222 tree cond
= build3_loc (input_location
, COND_EXPR
,
3223 void_type_node
, present
,
3224 cond_body
, NULL_TREE
);
3225 gfc_add_expr_to_block (block
, cond
);
3226 OMP_CLAUSE_SIZE (node
) = var
;
3230 gfc_add_block_to_block (block
, &cond_block
);
3231 OMP_CLAUSE_SIZE (node
) = size
;
3234 if (n
->sym
->attr
.dimension
)
3237 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3238 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3239 OMP_CLAUSE_SIZE (node
)
3240 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3241 OMP_CLAUSE_SIZE (node
), elemsz
);
3245 && TREE_CODE (decl
) == INDIRECT_REF
3246 && (TREE_CODE (TREE_OPERAND (decl
, 0))
3249 /* A single indirectref is handled by the middle end. */
3250 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl
)));
3251 decl
= TREE_OPERAND (decl
, 0);
3252 decl
= gfc_build_cond_assign_expr (block
, present
, decl
,
3254 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (decl
);
3257 OMP_CLAUSE_DECL (node
) = decl
;
3260 && n
->expr
->expr_type
== EXPR_VARIABLE
3261 && n
->expr
->ref
->type
== REF_ARRAY
3262 && !n
->expr
->ref
->next
)
3264 /* An array element or array section which is not part of a
3265 derived type, etc. */
3266 bool element
= n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
;
3267 gfc_trans_omp_array_section (block
, n
, decl
, element
,
3268 GOMP_MAP_POINTER
, node
, node2
,
3272 && n
->expr
->expr_type
== EXPR_VARIABLE
3273 && (n
->expr
->ref
->type
== REF_COMPONENT
3274 || n
->expr
->ref
->type
== REF_ARRAY
)
3276 && lastref
->type
== REF_COMPONENT
3277 && lastref
->u
.c
.component
->ts
.type
!= BT_CLASS
3278 && lastref
->u
.c
.component
->ts
.type
!= BT_DERIVED
3279 && !lastref
->u
.c
.component
->attr
.dimension
)
3281 /* Derived type access with last component being a scalar. */
3282 gfc_init_se (&se
, NULL
);
3284 gfc_conv_expr (&se
, n
->expr
);
3285 gfc_add_block_to_block (block
, &se
.pre
);
3286 /* For BT_CHARACTER a pointer is returned. */
3287 OMP_CLAUSE_DECL (node
)
3288 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
3289 ? build_fold_indirect_ref (se
.expr
) : se
.expr
;
3290 gfc_add_block_to_block (block
, &se
.post
);
3291 if (pointer
|| allocatable
)
3293 node2
= build_omp_clause (input_location
,
3296 = (openacc
? GOMP_MAP_ATTACH_DETACH
3297 : GOMP_MAP_ALWAYS_POINTER
);
3298 OMP_CLAUSE_SET_MAP_KIND (node2
, kind
);
3299 OMP_CLAUSE_DECL (node2
)
3300 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
3302 : gfc_build_addr_expr (NULL
, se
.expr
);
3303 OMP_CLAUSE_SIZE (node2
) = size_int (0);
3305 && n
->expr
->ts
.type
== BT_CHARACTER
3306 && n
->expr
->ts
.deferred
)
3308 gcc_assert (se
.string_length
);
3310 = gfc_get_char_type (n
->expr
->ts
.kind
);
3311 OMP_CLAUSE_SIZE (node
)
3312 = fold_build2 (MULT_EXPR
, size_type_node
,
3313 fold_convert (size_type_node
,
3315 TYPE_SIZE_UNIT (tmp
));
3316 node3
= build_omp_clause (input_location
,
3318 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_TO
);
3319 OMP_CLAUSE_DECL (node3
) = se
.string_length
;
3320 OMP_CLAUSE_SIZE (node3
)
3321 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
3326 && n
->expr
->expr_type
== EXPR_VARIABLE
3327 && (n
->expr
->ref
->type
== REF_COMPONENT
3328 || n
->expr
->ref
->type
== REF_ARRAY
))
3330 gfc_init_se (&se
, NULL
);
3331 se
.expr
= gfc_maybe_dereference_var (n
->sym
, decl
);
3333 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
3335 if (ref
->type
== REF_COMPONENT
)
3337 if (ref
->u
.c
.sym
->attr
.extension
)
3338 conv_parent_component_references (&se
, ref
);
3340 gfc_conv_component_ref (&se
, ref
);
3342 else if (ref
->type
== REF_ARRAY
)
3344 if (ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->next
)
3345 gfc_conv_array_ref (&se
, &ref
->u
.ar
, n
->expr
,
3348 gcc_assert (!ref
->next
);
3351 sorry ("unhandled expression type");
3354 tree inner
= se
.expr
;
3356 /* Last component is a derived type or class pointer. */
3357 if (lastref
->type
== REF_COMPONENT
3358 && (lastref
->u
.c
.component
->ts
.type
== BT_DERIVED
3359 || lastref
->u
.c
.component
->ts
.type
== BT_CLASS
))
3361 if (pointer
|| (openacc
&& allocatable
))
3365 if (lastref
->u
.c
.component
->ts
.type
== BT_CLASS
)
3367 data
= gfc_class_data_get (inner
);
3368 gcc_assert (POINTER_TYPE_P (TREE_TYPE (data
)));
3369 data
= build_fold_indirect_ref (data
);
3370 size
= gfc_class_vtab_size_get (inner
);
3372 else /* BT_DERIVED. */
3375 size
= TYPE_SIZE_UNIT (TREE_TYPE (inner
));
3378 OMP_CLAUSE_DECL (node
) = data
;
3379 OMP_CLAUSE_SIZE (node
) = size
;
3380 node2
= build_omp_clause (input_location
,
3382 OMP_CLAUSE_SET_MAP_KIND (node2
,
3384 ? GOMP_MAP_ATTACH_DETACH
3385 : GOMP_MAP_ALWAYS_POINTER
);
3386 OMP_CLAUSE_DECL (node2
) = build_fold_addr_expr (data
);
3387 OMP_CLAUSE_SIZE (node2
) = size_int (0);
3391 OMP_CLAUSE_DECL (node
) = inner
;
3392 OMP_CLAUSE_SIZE (node
)
3393 = TYPE_SIZE_UNIT (TREE_TYPE (inner
));
3396 else if (lastref
->type
== REF_ARRAY
3397 && lastref
->u
.ar
.type
== AR_FULL
)
3399 /* Just pass the (auto-dereferenced) decl through for
3400 bare attach and detach clauses. */
3401 if (n
->u
.map_op
== OMP_MAP_ATTACH
3402 || n
->u
.map_op
== OMP_MAP_DETACH
)
3404 OMP_CLAUSE_DECL (node
) = inner
;
3405 OMP_CLAUSE_SIZE (node
) = size_zero_node
;
3406 goto finalize_map_clause
;
3409 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner
)))
3411 gomp_map_kind map_kind
;
3413 tree type
= TREE_TYPE (inner
);
3414 tree ptr
= gfc_conv_descriptor_data_get (inner
);
3415 ptr
= build_fold_indirect_ref (ptr
);
3416 OMP_CLAUSE_DECL (node
) = ptr
;
3417 int rank
= GFC_TYPE_ARRAY_RANK (type
);
3418 OMP_CLAUSE_SIZE (node
)
3419 = gfc_full_array_size (block
, inner
, rank
);
3421 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3422 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
3423 map_kind
= GOMP_MAP_TO
;
3424 else if (n
->u
.map_op
== OMP_MAP_RELEASE
3425 || n
->u
.map_op
== OMP_MAP_DELETE
)
3426 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
3428 map_kind
= GOMP_MAP_ALLOC
;
3430 && n
->expr
->ts
.type
== BT_CHARACTER
3431 && n
->expr
->ts
.deferred
)
3433 gcc_assert (se
.string_length
);
3434 tree len
= fold_convert (size_type_node
,
3436 elemsz
= gfc_get_char_type (n
->expr
->ts
.kind
);
3437 elemsz
= TYPE_SIZE_UNIT (elemsz
);
3438 elemsz
= fold_build2 (MULT_EXPR
, size_type_node
,
3440 node4
= build_omp_clause (input_location
,
3442 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
3443 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
3444 OMP_CLAUSE_SIZE (node4
)
3445 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
3447 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3448 OMP_CLAUSE_SIZE (node
)
3449 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3450 OMP_CLAUSE_SIZE (node
), elemsz
);
3451 desc_node
= build_omp_clause (input_location
,
3454 OMP_CLAUSE_SET_MAP_KIND (desc_node
,
3457 OMP_CLAUSE_SET_MAP_KIND (desc_node
, map_kind
);
3458 OMP_CLAUSE_DECL (desc_node
) = inner
;
3459 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
3465 node
= desc_node
; /* Put first. */
3467 node3
= build_omp_clause (input_location
,
3469 OMP_CLAUSE_SET_MAP_KIND (node3
,
3471 ? GOMP_MAP_ATTACH_DETACH
3472 : GOMP_MAP_ALWAYS_POINTER
);
3473 OMP_CLAUSE_DECL (node3
)
3474 = gfc_conv_descriptor_data_get (inner
);
3475 /* Similar to gfc_trans_omp_array_section (details
3476 there), we add/keep the cast for OpenMP to prevent
3477 that an 'alloc:' gets added for node3 ('desc.data')
3478 as that is part of the whole descriptor (node3).
3479 TODO: Remove once the ME handles this properly. */
3481 OMP_CLAUSE_DECL (node3
)
3482 = fold_convert (TREE_TYPE (TREE_OPERAND(ptr
, 0)),
3483 OMP_CLAUSE_DECL (node3
));
3485 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
3486 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3489 OMP_CLAUSE_DECL (node
) = inner
;
3491 else if (lastref
->type
== REF_ARRAY
)
3493 /* An array element or section. */
3494 bool element
= lastref
->u
.ar
.type
== AR_ELEMENT
;
3495 gomp_map_kind kind
= (openacc
? GOMP_MAP_ATTACH_DETACH
3496 : GOMP_MAP_ALWAYS_POINTER
);
3497 gfc_trans_omp_array_section (block
, n
, inner
, element
,
3498 kind
, node
, node2
, node3
,
3505 sorry ("unhandled expression");
3507 finalize_map_clause
:
3509 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3511 omp_clauses
= gfc_trans_add_clause (node2
, omp_clauses
);
3513 omp_clauses
= gfc_trans_add_clause (node3
, omp_clauses
);
3515 omp_clauses
= gfc_trans_add_clause (node4
, omp_clauses
);
3520 case OMP_LIST_CACHE
:
3521 for (; n
!= NULL
; n
= n
->next
)
3523 if (!n
->sym
->attr
.referenced
)
3529 clause_code
= OMP_CLAUSE_TO
;
3532 clause_code
= OMP_CLAUSE_FROM
;
3534 case OMP_LIST_CACHE
:
3535 clause_code
= OMP_CLAUSE__CACHE_
;
3540 tree node
= build_omp_clause (input_location
, clause_code
);
3541 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
3543 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
3544 if (gfc_omp_privatize_by_reference (decl
))
3546 if (gfc_omp_is_allocatable_or_ptr (decl
))
3547 decl
= build_fold_indirect_ref (decl
);
3548 decl
= build_fold_indirect_ref (decl
);
3550 else if (DECL_P (decl
))
3551 TREE_ADDRESSABLE (decl
) = 1;
3552 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
3554 tree type
= TREE_TYPE (decl
);
3555 tree ptr
= gfc_conv_descriptor_data_get (decl
);
3556 ptr
= fold_convert (build_pointer_type (char_type_node
),
3558 ptr
= build_fold_indirect_ref (ptr
);
3559 OMP_CLAUSE_DECL (node
) = ptr
;
3560 OMP_CLAUSE_SIZE (node
)
3561 = gfc_full_array_size (block
, decl
,
3562 GFC_TYPE_ARRAY_RANK (type
));
3564 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3565 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3566 OMP_CLAUSE_SIZE (node
)
3567 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3568 OMP_CLAUSE_SIZE (node
), elemsz
);
3572 OMP_CLAUSE_DECL (node
) = decl
;
3573 if (gfc_omp_is_allocatable_or_ptr (decl
))
3574 OMP_CLAUSE_SIZE (node
)
3575 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl
)));
3581 gfc_init_se (&se
, NULL
);
3582 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
3584 gfc_conv_expr_reference (&se
, n
->expr
);
3586 gfc_add_block_to_block (block
, &se
.pre
);
3587 OMP_CLAUSE_SIZE (node
)
3588 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
3592 gfc_conv_expr_descriptor (&se
, n
->expr
);
3593 ptr
= gfc_conv_array_data (se
.expr
);
3594 tree type
= TREE_TYPE (se
.expr
);
3595 gfc_add_block_to_block (block
, &se
.pre
);
3596 OMP_CLAUSE_SIZE (node
)
3597 = gfc_full_array_size (block
, se
.expr
,
3598 GFC_TYPE_ARRAY_RANK (type
));
3600 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3601 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3602 OMP_CLAUSE_SIZE (node
)
3603 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3604 OMP_CLAUSE_SIZE (node
), elemsz
);
3606 gfc_add_block_to_block (block
, &se
.post
);
3607 ptr
= fold_convert (build_pointer_type (char_type_node
),
3609 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
3611 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3619 if (clauses
->if_expr
)
3623 gfc_init_se (&se
, NULL
);
3624 gfc_conv_expr (&se
, clauses
->if_expr
);
3625 gfc_add_block_to_block (block
, &se
.pre
);
3626 if_var
= gfc_evaluate_now (se
.expr
, block
);
3627 gfc_add_block_to_block (block
, &se
.post
);
3629 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3630 OMP_CLAUSE_IF_MODIFIER (c
) = ERROR_MARK
;
3631 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3632 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3634 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
3635 if (clauses
->if_exprs
[ifc
])
3639 gfc_init_se (&se
, NULL
);
3640 gfc_conv_expr (&se
, clauses
->if_exprs
[ifc
]);
3641 gfc_add_block_to_block (block
, &se
.pre
);
3642 if_var
= gfc_evaluate_now (se
.expr
, block
);
3643 gfc_add_block_to_block (block
, &se
.post
);
3645 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3649 OMP_CLAUSE_IF_MODIFIER (c
) = VOID_CST
;
3651 case OMP_IF_PARALLEL
:
3652 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_PARALLEL
;
3655 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_SIMD
;
3658 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASK
;
3660 case OMP_IF_TASKLOOP
:
3661 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASKLOOP
;
3664 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET
;
3666 case OMP_IF_TARGET_DATA
:
3667 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_DATA
;
3669 case OMP_IF_TARGET_UPDATE
:
3670 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_UPDATE
;
3672 case OMP_IF_TARGET_ENTER_DATA
:
3673 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_ENTER_DATA
;
3675 case OMP_IF_TARGET_EXIT_DATA
:
3676 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_EXIT_DATA
;
3681 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3682 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3685 if (clauses
->final_expr
)
3689 gfc_init_se (&se
, NULL
);
3690 gfc_conv_expr (&se
, clauses
->final_expr
);
3691 gfc_add_block_to_block (block
, &se
.pre
);
3692 final_var
= gfc_evaluate_now (se
.expr
, block
);
3693 gfc_add_block_to_block (block
, &se
.post
);
3695 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINAL
);
3696 OMP_CLAUSE_FINAL_EXPR (c
) = final_var
;
3697 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3700 if (clauses
->num_threads
)
3704 gfc_init_se (&se
, NULL
);
3705 gfc_conv_expr (&se
, clauses
->num_threads
);
3706 gfc_add_block_to_block (block
, &se
.pre
);
3707 num_threads
= gfc_evaluate_now (se
.expr
, block
);
3708 gfc_add_block_to_block (block
, &se
.post
);
3710 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_THREADS
);
3711 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
3712 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3715 chunk_size
= NULL_TREE
;
3716 if (clauses
->chunk_size
)
3718 gfc_init_se (&se
, NULL
);
3719 gfc_conv_expr (&se
, clauses
->chunk_size
);
3720 gfc_add_block_to_block (block
, &se
.pre
);
3721 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3722 gfc_add_block_to_block (block
, &se
.post
);
3725 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
3727 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SCHEDULE
);
3728 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3729 switch (clauses
->sched_kind
)
3731 case OMP_SCHED_STATIC
:
3732 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
3734 case OMP_SCHED_DYNAMIC
:
3735 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
3737 case OMP_SCHED_GUIDED
:
3738 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
3740 case OMP_SCHED_RUNTIME
:
3741 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
3743 case OMP_SCHED_AUTO
:
3744 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
3749 if (clauses
->sched_monotonic
)
3750 OMP_CLAUSE_SCHEDULE_KIND (c
)
3751 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3752 | OMP_CLAUSE_SCHEDULE_MONOTONIC
);
3753 else if (clauses
->sched_nonmonotonic
)
3754 OMP_CLAUSE_SCHEDULE_KIND (c
)
3755 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3756 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC
);
3757 if (clauses
->sched_simd
)
3758 OMP_CLAUSE_SCHEDULE_SIMD (c
) = 1;
3759 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3762 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
3764 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULT
);
3765 switch (clauses
->default_sharing
)
3767 case OMP_DEFAULT_NONE
:
3768 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
3770 case OMP_DEFAULT_SHARED
:
3771 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
3773 case OMP_DEFAULT_PRIVATE
:
3774 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
3776 case OMP_DEFAULT_FIRSTPRIVATE
:
3777 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
3779 case OMP_DEFAULT_PRESENT
:
3780 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRESENT
;
3785 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3788 if (clauses
->nowait
)
3790 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOWAIT
);
3791 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3794 if (clauses
->ordered
)
3796 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDERED
);
3797 OMP_CLAUSE_ORDERED_EXPR (c
)
3798 = clauses
->orderedc
? build_int_cst (integer_type_node
,
3799 clauses
->orderedc
) : NULL_TREE
;
3800 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3803 if (clauses
->order_concurrent
)
3805 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDER
);
3806 OMP_CLAUSE_ORDER_UNCONSTRAINED (c
) = clauses
->order_unconstrained
;
3807 OMP_CLAUSE_ORDER_REPRODUCIBLE (c
) = clauses
->order_reproducible
;
3808 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3811 if (clauses
->untied
)
3813 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_UNTIED
);
3814 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3817 if (clauses
->mergeable
)
3819 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_MERGEABLE
);
3820 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3823 if (clauses
->collapse
)
3825 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_COLLAPSE
);
3826 OMP_CLAUSE_COLLAPSE_EXPR (c
)
3827 = build_int_cst (integer_type_node
, clauses
->collapse
);
3828 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3831 if (clauses
->inbranch
)
3833 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INBRANCH
);
3834 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3837 if (clauses
->notinbranch
)
3839 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOTINBRANCH
);
3840 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3843 switch (clauses
->cancel
)
3845 case OMP_CANCEL_UNKNOWN
:
3847 case OMP_CANCEL_PARALLEL
:
3848 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PARALLEL
);
3849 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3851 case OMP_CANCEL_SECTIONS
:
3852 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SECTIONS
);
3853 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3856 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FOR
);
3857 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3859 case OMP_CANCEL_TASKGROUP
:
3860 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TASKGROUP
);
3861 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3865 if (clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
3867 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PROC_BIND
);
3868 switch (clauses
->proc_bind
)
3870 case OMP_PROC_BIND_PRIMARY
:
3871 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_PRIMARY
;
3873 case OMP_PROC_BIND_MASTER
:
3874 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_MASTER
;
3876 case OMP_PROC_BIND_SPREAD
:
3877 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_SPREAD
;
3879 case OMP_PROC_BIND_CLOSE
:
3880 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_CLOSE
;
3885 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3888 if (clauses
->safelen_expr
)
3892 gfc_init_se (&se
, NULL
);
3893 gfc_conv_expr (&se
, clauses
->safelen_expr
);
3894 gfc_add_block_to_block (block
, &se
.pre
);
3895 safelen_var
= gfc_evaluate_now (se
.expr
, block
);
3896 gfc_add_block_to_block (block
, &se
.post
);
3898 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SAFELEN
);
3899 OMP_CLAUSE_SAFELEN_EXPR (c
) = safelen_var
;
3900 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3903 if (clauses
->simdlen_expr
)
3907 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3908 OMP_CLAUSE_SIMDLEN_EXPR (c
)
3909 = gfc_conv_constant_to_tree (clauses
->simdlen_expr
);
3910 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3916 gfc_init_se (&se
, NULL
);
3917 gfc_conv_expr (&se
, clauses
->simdlen_expr
);
3918 gfc_add_block_to_block (block
, &se
.pre
);
3919 simdlen_var
= gfc_evaluate_now (se
.expr
, block
);
3920 gfc_add_block_to_block (block
, &se
.post
);
3922 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3923 OMP_CLAUSE_SIMDLEN_EXPR (c
) = simdlen_var
;
3924 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3928 if (clauses
->num_teams
)
3932 gfc_init_se (&se
, NULL
);
3933 gfc_conv_expr (&se
, clauses
->num_teams
);
3934 gfc_add_block_to_block (block
, &se
.pre
);
3935 num_teams
= gfc_evaluate_now (se
.expr
, block
);
3936 gfc_add_block_to_block (block
, &se
.post
);
3938 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TEAMS
);
3939 OMP_CLAUSE_NUM_TEAMS_EXPR (c
) = num_teams
;
3940 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3943 if (clauses
->device
)
3947 gfc_init_se (&se
, NULL
);
3948 gfc_conv_expr (&se
, clauses
->device
);
3949 gfc_add_block_to_block (block
, &se
.pre
);
3950 device
= gfc_evaluate_now (se
.expr
, block
);
3951 gfc_add_block_to_block (block
, &se
.post
);
3953 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEVICE
);
3954 OMP_CLAUSE_DEVICE_ID (c
) = device
;
3956 if (clauses
->ancestor
)
3957 OMP_CLAUSE_DEVICE_ANCESTOR (c
) = 1;
3959 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3962 if (clauses
->thread_limit
)
3966 gfc_init_se (&se
, NULL
);
3967 gfc_conv_expr (&se
, clauses
->thread_limit
);
3968 gfc_add_block_to_block (block
, &se
.pre
);
3969 thread_limit
= gfc_evaluate_now (se
.expr
, block
);
3970 gfc_add_block_to_block (block
, &se
.post
);
3972 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREAD_LIMIT
);
3973 OMP_CLAUSE_THREAD_LIMIT_EXPR (c
) = thread_limit
;
3974 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3977 chunk_size
= NULL_TREE
;
3978 if (clauses
->dist_chunk_size
)
3980 gfc_init_se (&se
, NULL
);
3981 gfc_conv_expr (&se
, clauses
->dist_chunk_size
);
3982 gfc_add_block_to_block (block
, &se
.pre
);
3983 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3984 gfc_add_block_to_block (block
, &se
.post
);
3987 if (clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
3989 c
= build_omp_clause (gfc_get_location (&where
),
3990 OMP_CLAUSE_DIST_SCHEDULE
);
3991 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3992 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3995 if (clauses
->grainsize
)
3999 gfc_init_se (&se
, NULL
);
4000 gfc_conv_expr (&se
, clauses
->grainsize
);
4001 gfc_add_block_to_block (block
, &se
.pre
);
4002 grainsize
= gfc_evaluate_now (se
.expr
, block
);
4003 gfc_add_block_to_block (block
, &se
.post
);
4005 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GRAINSIZE
);
4006 OMP_CLAUSE_GRAINSIZE_EXPR (c
) = grainsize
;
4007 if (clauses
->grainsize_strict
)
4008 OMP_CLAUSE_GRAINSIZE_STRICT (c
) = 1;
4009 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4012 if (clauses
->num_tasks
)
4016 gfc_init_se (&se
, NULL
);
4017 gfc_conv_expr (&se
, clauses
->num_tasks
);
4018 gfc_add_block_to_block (block
, &se
.pre
);
4019 num_tasks
= gfc_evaluate_now (se
.expr
, block
);
4020 gfc_add_block_to_block (block
, &se
.post
);
4022 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TASKS
);
4023 OMP_CLAUSE_NUM_TASKS_EXPR (c
) = num_tasks
;
4024 if (clauses
->num_tasks_strict
)
4025 OMP_CLAUSE_NUM_TASKS_STRICT (c
) = 1;
4026 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4029 if (clauses
->priority
)
4033 gfc_init_se (&se
, NULL
);
4034 gfc_conv_expr (&se
, clauses
->priority
);
4035 gfc_add_block_to_block (block
, &se
.pre
);
4036 priority
= gfc_evaluate_now (se
.expr
, block
);
4037 gfc_add_block_to_block (block
, &se
.post
);
4039 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PRIORITY
);
4040 OMP_CLAUSE_PRIORITY_EXPR (c
) = priority
;
4041 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4044 if (clauses
->detach
)
4048 gfc_init_se (&se
, NULL
);
4049 gfc_conv_expr (&se
, clauses
->detach
);
4050 gfc_add_block_to_block (block
, &se
.pre
);
4052 gfc_add_block_to_block (block
, &se
.post
);
4054 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DETACH
);
4055 TREE_ADDRESSABLE (detach
) = 1;
4056 OMP_CLAUSE_DECL (c
) = detach
;
4057 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4060 if (clauses
->filter
)
4064 gfc_init_se (&se
, NULL
);
4065 gfc_conv_expr (&se
, clauses
->filter
);
4066 gfc_add_block_to_block (block
, &se
.pre
);
4067 filter
= gfc_evaluate_now (se
.expr
, block
);
4068 gfc_add_block_to_block (block
, &se
.post
);
4070 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FILTER
);
4071 OMP_CLAUSE_FILTER_EXPR (c
) = filter
;
4072 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4079 gfc_init_se (&se
, NULL
);
4080 gfc_conv_expr (&se
, clauses
->hint
);
4081 gfc_add_block_to_block (block
, &se
.pre
);
4082 hint
= gfc_evaluate_now (se
.expr
, block
);
4083 gfc_add_block_to_block (block
, &se
.post
);
4085 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_HINT
);
4086 OMP_CLAUSE_HINT_EXPR (c
) = hint
;
4087 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4092 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMD
);
4093 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4095 if (clauses
->threads
)
4097 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREADS
);
4098 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4100 if (clauses
->nogroup
)
4102 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOGROUP
);
4103 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4106 for (int i
= 0; i
< OMP_DEFAULTMAP_CAT_NUM
; i
++)
4108 if (clauses
->defaultmap
[i
] == OMP_DEFAULTMAP_UNSET
)
4110 enum omp_clause_defaultmap_kind behavior
, category
;
4111 switch ((gfc_omp_defaultmap_category
) i
)
4113 case OMP_DEFAULTMAP_CAT_UNCATEGORIZED
:
4114 category
= OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED
;
4116 case OMP_DEFAULTMAP_CAT_SCALAR
:
4117 category
= OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR
;
4119 case OMP_DEFAULTMAP_CAT_AGGREGATE
:
4120 category
= OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE
;
4122 case OMP_DEFAULTMAP_CAT_ALLOCATABLE
:
4123 category
= OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE
;
4125 case OMP_DEFAULTMAP_CAT_POINTER
:
4126 category
= OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER
;
4128 default: gcc_unreachable ();
4130 switch (clauses
->defaultmap
[i
])
4132 case OMP_DEFAULTMAP_ALLOC
:
4133 behavior
= OMP_CLAUSE_DEFAULTMAP_ALLOC
;
4135 case OMP_DEFAULTMAP_TO
: behavior
= OMP_CLAUSE_DEFAULTMAP_TO
; break;
4136 case OMP_DEFAULTMAP_FROM
: behavior
= OMP_CLAUSE_DEFAULTMAP_FROM
; break;
4137 case OMP_DEFAULTMAP_TOFROM
:
4138 behavior
= OMP_CLAUSE_DEFAULTMAP_TOFROM
;
4140 case OMP_DEFAULTMAP_FIRSTPRIVATE
:
4141 behavior
= OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE
;
4143 case OMP_DEFAULTMAP_NONE
: behavior
= OMP_CLAUSE_DEFAULTMAP_NONE
; break;
4144 case OMP_DEFAULTMAP_DEFAULT
:
4145 behavior
= OMP_CLAUSE_DEFAULTMAP_DEFAULT
;
4147 default: gcc_unreachable ();
4149 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULTMAP
);
4150 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c
, behavior
, category
);
4151 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4154 if (clauses
->depend_source
)
4156 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEPEND
);
4157 OMP_CLAUSE_DEPEND_KIND (c
) = OMP_CLAUSE_DEPEND_SOURCE
;
4158 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4163 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ASYNC
);
4164 if (clauses
->async_expr
)
4165 OMP_CLAUSE_ASYNC_EXPR (c
)
4166 = gfc_convert_expr_to_tree (block
, clauses
->async_expr
);
4168 OMP_CLAUSE_ASYNC_EXPR (c
) = NULL
;
4169 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4173 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SEQ
);
4174 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4176 if (clauses
->par_auto
)
4178 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_AUTO
);
4179 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4181 if (clauses
->if_present
)
4183 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF_PRESENT
);
4184 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4186 if (clauses
->finalize
)
4188 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINALIZE
);
4189 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4191 if (clauses
->independent
)
4193 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INDEPENDENT
);
4194 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4196 if (clauses
->wait_list
)
4200 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
4202 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WAIT
);
4203 OMP_CLAUSE_DECL (c
) = gfc_convert_expr_to_tree (block
, el
->expr
);
4204 OMP_CLAUSE_CHAIN (c
) = omp_clauses
;
4208 if (clauses
->num_gangs_expr
)
4211 = gfc_convert_expr_to_tree (block
, clauses
->num_gangs_expr
);
4212 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_GANGS
);
4213 OMP_CLAUSE_NUM_GANGS_EXPR (c
) = num_gangs_var
;
4214 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4216 if (clauses
->num_workers_expr
)
4218 tree num_workers_var
4219 = gfc_convert_expr_to_tree (block
, clauses
->num_workers_expr
);
4220 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_WORKERS
);
4221 OMP_CLAUSE_NUM_WORKERS_EXPR (c
) = num_workers_var
;
4222 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4224 if (clauses
->vector_length_expr
)
4226 tree vector_length_var
4227 = gfc_convert_expr_to_tree (block
, clauses
->vector_length_expr
);
4228 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR_LENGTH
);
4229 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c
) = vector_length_var
;
4230 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4232 if (clauses
->tile_list
)
4234 vec
<tree
, va_gc
> *tvec
;
4237 vec_alloc (tvec
, 4);
4239 for (el
= clauses
->tile_list
; el
; el
= el
->next
)
4240 vec_safe_push (tvec
, gfc_convert_expr_to_tree (block
, el
->expr
));
4242 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TILE
);
4243 OMP_CLAUSE_TILE_LIST (c
) = build_tree_list_vec (tvec
);
4244 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4247 if (clauses
->vector
)
4249 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR
);
4250 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4252 if (clauses
->vector_expr
)
4255 = gfc_convert_expr_to_tree (block
, clauses
->vector_expr
);
4256 OMP_CLAUSE_VECTOR_EXPR (c
) = vector_var
;
4258 /* TODO: We're not capturing location information for individual
4259 clauses. However, if we have an expression attached to the
4260 clause, that one provides better location information. */
4261 OMP_CLAUSE_LOCATION (c
)
4262 = gfc_get_location (&clauses
->vector_expr
->where
);
4265 if (clauses
->worker
)
4267 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WORKER
);
4268 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4270 if (clauses
->worker_expr
)
4273 = gfc_convert_expr_to_tree (block
, clauses
->worker_expr
);
4274 OMP_CLAUSE_WORKER_EXPR (c
) = worker_var
;
4276 /* TODO: We're not capturing location information for individual
4277 clauses. However, if we have an expression attached to the
4278 clause, that one provides better location information. */
4279 OMP_CLAUSE_LOCATION (c
)
4280 = gfc_get_location (&clauses
->worker_expr
->where
);
4286 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GANG
);
4287 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4289 if (clauses
->gang_num_expr
)
4291 arg
= gfc_convert_expr_to_tree (block
, clauses
->gang_num_expr
);
4292 OMP_CLAUSE_GANG_EXPR (c
) = arg
;
4294 /* TODO: We're not capturing location information for individual
4295 clauses. However, if we have an expression attached to the
4296 clause, that one provides better location information. */
4297 OMP_CLAUSE_LOCATION (c
)
4298 = gfc_get_location (&clauses
->gang_num_expr
->where
);
4301 if (clauses
->gang_static
)
4303 arg
= clauses
->gang_static_expr
4304 ? gfc_convert_expr_to_tree (block
, clauses
->gang_static_expr
)
4305 : integer_minus_one_node
;
4306 OMP_CLAUSE_GANG_STATIC_EXPR (c
) = arg
;
4309 if (clauses
->bind
!= OMP_BIND_UNSET
)
4311 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_BIND
);
4312 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
4313 switch (clauses
->bind
)
4315 case OMP_BIND_TEAMS
:
4316 OMP_CLAUSE_BIND_KIND (c
) = OMP_CLAUSE_BIND_TEAMS
;
4318 case OMP_BIND_PARALLEL
:
4319 OMP_CLAUSE_BIND_KIND (c
) = OMP_CLAUSE_BIND_PARALLEL
;
4321 case OMP_BIND_THREAD
:
4322 OMP_CLAUSE_BIND_KIND (c
) = OMP_CLAUSE_BIND_THREAD
;
4328 /* OpenACC 'nohost' clauses cannot appear here. */
4329 gcc_checking_assert (!clauses
->nohost
);
4331 return nreverse (omp_clauses
);
4334 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
4337 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
4342 stmt
= gfc_trans_code (code
);
4343 if (TREE_CODE (stmt
) != BIND_EXPR
)
4345 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
4347 tree block
= poplevel (1, 0);
4348 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
4358 /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
4362 gfc_trans_oacc_construct (gfc_code
*code
)
4365 tree stmt
, oacc_clauses
;
4366 enum tree_code construct_code
;
4370 case EXEC_OACC_PARALLEL
:
4371 construct_code
= OACC_PARALLEL
;
4373 case EXEC_OACC_KERNELS
:
4374 construct_code
= OACC_KERNELS
;
4376 case EXEC_OACC_SERIAL
:
4377 construct_code
= OACC_SERIAL
;
4379 case EXEC_OACC_DATA
:
4380 construct_code
= OACC_DATA
;
4382 case EXEC_OACC_HOST_DATA
:
4383 construct_code
= OACC_HOST_DATA
;
4389 gfc_start_block (&block
);
4390 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4391 code
->loc
, false, true);
4392 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4393 stmt
= build2_loc (gfc_get_location (&code
->loc
), construct_code
,
4394 void_type_node
, stmt
, oacc_clauses
);
4395 gfc_add_expr_to_block (&block
, stmt
);
4396 return gfc_finish_block (&block
);
4399 /* update, enter_data, exit_data, cache. */
4401 gfc_trans_oacc_executable_directive (gfc_code
*code
)
4404 tree stmt
, oacc_clauses
;
4405 enum tree_code construct_code
;
4409 case EXEC_OACC_UPDATE
:
4410 construct_code
= OACC_UPDATE
;
4412 case EXEC_OACC_ENTER_DATA
:
4413 construct_code
= OACC_ENTER_DATA
;
4415 case EXEC_OACC_EXIT_DATA
:
4416 construct_code
= OACC_EXIT_DATA
;
4418 case EXEC_OACC_CACHE
:
4419 construct_code
= OACC_CACHE
;
4425 gfc_start_block (&block
);
4426 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4427 code
->loc
, false, true);
4428 stmt
= build1_loc (input_location
, construct_code
, void_type_node
,
4430 gfc_add_expr_to_block (&block
, stmt
);
4431 return gfc_finish_block (&block
);
4435 gfc_trans_oacc_wait_directive (gfc_code
*code
)
4439 vec
<tree
, va_gc
> *args
;
4442 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
4443 location_t loc
= input_location
;
4445 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
4448 vec_alloc (args
, nparms
+ 2);
4449 stmt
= builtin_decl_explicit (BUILT_IN_GOACC_WAIT
);
4451 gfc_start_block (&block
);
4453 if (clauses
->async_expr
)
4454 t
= gfc_convert_expr_to_tree (&block
, clauses
->async_expr
);
4456 t
= build_int_cst (integer_type_node
, -2);
4458 args
->quick_push (t
);
4459 args
->quick_push (build_int_cst (integer_type_node
, nparms
));
4461 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
4462 args
->quick_push (gfc_convert_expr_to_tree (&block
, el
->expr
));
4464 stmt
= build_call_expr_loc_vec (loc
, stmt
, args
);
4465 gfc_add_expr_to_block (&block
, stmt
);
4469 return gfc_finish_block (&block
);
4472 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
4473 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
4476 gfc_trans_omp_atomic (gfc_code
*code
)
4478 gfc_code
*atomic_code
= code
->block
;
4482 gfc_expr
*expr2
, *e
;
4485 tree lhsaddr
, type
, rhs
, x
;
4486 enum tree_code op
= ERROR_MARK
;
4487 enum tree_code aop
= OMP_ATOMIC
;
4488 bool var_on_left
= false;
4489 enum omp_memory_order mo
;
4490 switch (atomic_code
->ext
.omp_clauses
->memorder
)
4492 case OMP_MEMORDER_UNSET
: mo
= OMP_MEMORY_ORDER_UNSPECIFIED
; break;
4493 case OMP_MEMORDER_ACQ_REL
: mo
= OMP_MEMORY_ORDER_ACQ_REL
; break;
4494 case OMP_MEMORDER_ACQUIRE
: mo
= OMP_MEMORY_ORDER_ACQUIRE
; break;
4495 case OMP_MEMORDER_RELAXED
: mo
= OMP_MEMORY_ORDER_RELAXED
; break;
4496 case OMP_MEMORDER_RELEASE
: mo
= OMP_MEMORY_ORDER_RELEASE
; break;
4497 case OMP_MEMORDER_SEQ_CST
: mo
= OMP_MEMORY_ORDER_SEQ_CST
; break;
4498 default: gcc_unreachable ();
4501 code
= code
->block
->next
;
4502 gcc_assert (code
->op
== EXEC_ASSIGN
);
4503 var
= code
->expr1
->symtree
->n
.sym
;
4505 gfc_init_se (&lse
, NULL
);
4506 gfc_init_se (&rse
, NULL
);
4507 gfc_init_se (&vse
, NULL
);
4508 gfc_start_block (&block
);
4510 expr2
= code
->expr2
;
4511 if (((atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_MASK
)
4512 != GFC_OMP_ATOMIC_WRITE
)
4513 && expr2
->expr_type
== EXPR_FUNCTION
4514 && expr2
->value
.function
.isym
4515 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4516 expr2
= expr2
->value
.function
.actual
->expr
;
4518 if ((atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_MASK
)
4519 == GFC_OMP_ATOMIC_READ
)
4521 gfc_conv_expr (&vse
, code
->expr1
);
4522 gfc_add_block_to_block (&block
, &vse
.pre
);
4524 gfc_conv_expr (&lse
, expr2
);
4525 gfc_add_block_to_block (&block
, &lse
.pre
);
4526 type
= TREE_TYPE (lse
.expr
);
4527 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
4529 x
= build1 (OMP_ATOMIC_READ
, type
, lhsaddr
);
4530 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4531 x
= convert (TREE_TYPE (vse
.expr
), x
);
4532 gfc_add_modify (&block
, vse
.expr
, x
);
4534 gfc_add_block_to_block (&block
, &lse
.pre
);
4535 gfc_add_block_to_block (&block
, &rse
.pre
);
4537 return gfc_finish_block (&block
);
4539 if (atomic_code
->ext
.omp_clauses
->capture
)
4541 aop
= OMP_ATOMIC_CAPTURE_NEW
;
4542 if (expr2
->expr_type
== EXPR_VARIABLE
)
4544 aop
= OMP_ATOMIC_CAPTURE_OLD
;
4545 gfc_conv_expr (&vse
, code
->expr1
);
4546 gfc_add_block_to_block (&block
, &vse
.pre
);
4548 gfc_conv_expr (&lse
, expr2
);
4549 gfc_add_block_to_block (&block
, &lse
.pre
);
4550 gfc_init_se (&lse
, NULL
);
4552 var
= code
->expr1
->symtree
->n
.sym
;
4553 expr2
= code
->expr2
;
4554 if (expr2
->expr_type
== EXPR_FUNCTION
4555 && expr2
->value
.function
.isym
4556 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4557 expr2
= expr2
->value
.function
.actual
->expr
;
4561 gfc_conv_expr (&lse
, code
->expr1
);
4562 gfc_add_block_to_block (&block
, &lse
.pre
);
4563 type
= TREE_TYPE (lse
.expr
);
4564 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
4566 if (((atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_MASK
)
4567 == GFC_OMP_ATOMIC_WRITE
)
4568 || (atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_SWAP
))
4570 gfc_conv_expr (&rse
, expr2
);
4571 gfc_add_block_to_block (&block
, &rse
.pre
);
4573 else if (expr2
->expr_type
== EXPR_OP
)
4576 switch (expr2
->value
.op
.op
)
4578 case INTRINSIC_PLUS
:
4581 case INTRINSIC_TIMES
:
4584 case INTRINSIC_MINUS
:
4587 case INTRINSIC_DIVIDE
:
4588 if (expr2
->ts
.type
== BT_INTEGER
)
4589 op
= TRUNC_DIV_EXPR
;
4594 op
= TRUTH_ANDIF_EXPR
;
4597 op
= TRUTH_ORIF_EXPR
;
4602 case INTRINSIC_NEQV
:
4608 e
= expr2
->value
.op
.op1
;
4609 if (e
->expr_type
== EXPR_FUNCTION
4610 && e
->value
.function
.isym
4611 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4612 e
= e
->value
.function
.actual
->expr
;
4613 if (e
->expr_type
== EXPR_VARIABLE
4614 && e
->symtree
!= NULL
4615 && e
->symtree
->n
.sym
== var
)
4617 expr2
= expr2
->value
.op
.op2
;
4622 e
= expr2
->value
.op
.op2
;
4623 if (e
->expr_type
== EXPR_FUNCTION
4624 && e
->value
.function
.isym
4625 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4626 e
= e
->value
.function
.actual
->expr
;
4627 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4628 && e
->symtree
!= NULL
4629 && e
->symtree
->n
.sym
== var
);
4630 expr2
= expr2
->value
.op
.op1
;
4631 var_on_left
= false;
4633 gfc_conv_expr (&rse
, expr2
);
4634 gfc_add_block_to_block (&block
, &rse
.pre
);
4638 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
4639 switch (expr2
->value
.function
.isym
->id
)
4659 e
= expr2
->value
.function
.actual
->expr
;
4660 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4661 && e
->symtree
!= NULL
4662 && e
->symtree
->n
.sym
== var
);
4664 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
4665 gfc_add_block_to_block (&block
, &rse
.pre
);
4666 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
4668 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
4669 gfc_actual_arglist
*arg
;
4671 gfc_add_modify (&block
, accum
, rse
.expr
);
4672 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
4675 gfc_init_block (&rse
.pre
);
4676 gfc_conv_expr (&rse
, arg
->expr
);
4677 gfc_add_block_to_block (&block
, &rse
.pre
);
4678 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (accum
),
4680 gfc_add_modify (&block
, accum
, x
);
4686 expr2
= expr2
->value
.function
.actual
->next
->expr
;
4689 lhsaddr
= save_expr (lhsaddr
);
4690 if (TREE_CODE (lhsaddr
) != SAVE_EXPR
4691 && (TREE_CODE (lhsaddr
) != ADDR_EXPR
4692 || !VAR_P (TREE_OPERAND (lhsaddr
, 0))))
4694 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
4695 it even after unsharing function body. */
4696 tree var
= create_tmp_var_raw (TREE_TYPE (lhsaddr
));
4697 DECL_CONTEXT (var
) = current_function_decl
;
4698 lhsaddr
= build4 (TARGET_EXPR
, TREE_TYPE (lhsaddr
), var
, lhsaddr
,
4699 NULL_TREE
, NULL_TREE
);
4702 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
4704 if (((atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_MASK
)
4705 == GFC_OMP_ATOMIC_WRITE
)
4706 || (atomic_code
->ext
.omp_clauses
->atomic_op
& GFC_OMP_ATOMIC_SWAP
))
4710 x
= convert (TREE_TYPE (rhs
),
4711 build_fold_indirect_ref_loc (input_location
, lhsaddr
));
4713 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), x
, rhs
);
4715 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), rhs
, x
);
4718 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
4719 && TREE_CODE (type
) != COMPLEX_TYPE
)
4720 x
= fold_build1_loc (input_location
, REALPART_EXPR
,
4721 TREE_TYPE (TREE_TYPE (rhs
)), x
);
4723 gfc_add_block_to_block (&block
, &lse
.pre
);
4724 gfc_add_block_to_block (&block
, &rse
.pre
);
4726 if (aop
== OMP_ATOMIC
)
4728 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
4729 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4730 gfc_add_expr_to_block (&block
, x
);
4734 if (aop
== OMP_ATOMIC_CAPTURE_NEW
)
4737 expr2
= code
->expr2
;
4738 if (expr2
->expr_type
== EXPR_FUNCTION
4739 && expr2
->value
.function
.isym
4740 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4741 expr2
= expr2
->value
.function
.actual
->expr
;
4743 gcc_assert (expr2
->expr_type
== EXPR_VARIABLE
);
4744 gfc_conv_expr (&vse
, code
->expr1
);
4745 gfc_add_block_to_block (&block
, &vse
.pre
);
4747 gfc_init_se (&lse
, NULL
);
4748 gfc_conv_expr (&lse
, expr2
);
4749 gfc_add_block_to_block (&block
, &lse
.pre
);
4751 x
= build2 (aop
, type
, lhsaddr
, convert (type
, x
));
4752 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4753 x
= convert (TREE_TYPE (vse
.expr
), x
);
4754 gfc_add_modify (&block
, vse
.expr
, x
);
4757 return gfc_finish_block (&block
);
4761 gfc_trans_omp_barrier (void)
4763 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_BARRIER
);
4764 return build_call_expr_loc (input_location
, decl
, 0);
4768 gfc_trans_omp_cancel (gfc_code
*code
)
4771 tree ifc
= boolean_true_node
;
4773 switch (code
->ext
.omp_clauses
->cancel
)
4775 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4776 case OMP_CANCEL_DO
: mask
= 2; break;
4777 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4778 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4779 default: gcc_unreachable ();
4781 gfc_start_block (&block
);
4782 if (code
->ext
.omp_clauses
->if_expr
4783 || code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
])
4788 gcc_assert ((code
->ext
.omp_clauses
->if_expr
== NULL
)
4789 ^ (code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
] == NULL
));
4790 gfc_init_se (&se
, NULL
);
4791 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->if_expr
!= NULL
4792 ? code
->ext
.omp_clauses
->if_expr
4793 : code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
]);
4794 gfc_add_block_to_block (&block
, &se
.pre
);
4795 if_var
= gfc_evaluate_now (se
.expr
, &block
);
4796 gfc_add_block_to_block (&block
, &se
.post
);
4797 tree type
= TREE_TYPE (if_var
);
4798 ifc
= fold_build2_loc (input_location
, NE_EXPR
,
4799 boolean_type_node
, if_var
,
4800 build_zero_cst (type
));
4802 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCEL
);
4803 tree c_bool_type
= TREE_TYPE (TREE_TYPE (decl
));
4804 ifc
= fold_convert (c_bool_type
, ifc
);
4805 gfc_add_expr_to_block (&block
,
4806 build_call_expr_loc (input_location
, decl
, 2,
4807 build_int_cst (integer_type_node
,
4809 return gfc_finish_block (&block
);
4813 gfc_trans_omp_cancellation_point (gfc_code
*code
)
4816 switch (code
->ext
.omp_clauses
->cancel
)
4818 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4819 case OMP_CANCEL_DO
: mask
= 2; break;
4820 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4821 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4822 default: gcc_unreachable ();
4824 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT
);
4825 return build_call_expr_loc (input_location
, decl
, 1,
4826 build_int_cst (integer_type_node
, mask
));
4830 gfc_trans_omp_critical (gfc_code
*code
)
4833 tree stmt
, name
= NULL_TREE
;
4834 if (code
->ext
.omp_clauses
->critical_name
!= NULL
)
4835 name
= get_identifier (code
->ext
.omp_clauses
->critical_name
);
4836 gfc_start_block (&block
);
4837 stmt
= make_node (OMP_CRITICAL
);
4838 TREE_TYPE (stmt
) = void_type_node
;
4839 OMP_CRITICAL_BODY (stmt
) = gfc_trans_code (code
->block
->next
);
4840 OMP_CRITICAL_NAME (stmt
) = name
;
4841 OMP_CRITICAL_CLAUSES (stmt
) = gfc_trans_omp_clauses (&block
,
4842 code
->ext
.omp_clauses
,
4844 gfc_add_expr_to_block (&block
, stmt
);
4845 return gfc_finish_block (&block
);
4848 typedef struct dovar_init_d
{
4855 gfc_trans_omp_do (gfc_code
*code
, gfc_exec_op op
, stmtblock_t
*pblock
,
4856 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
4859 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
, orig_decls
;
4860 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
4863 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
4864 int i
, collapse
= clauses
->collapse
;
4865 vec
<dovar_init
> inits
= vNULL
;
4868 vec
<tree
, va_heap
, vl_embed
> *saved_doacross_steps
= doacross_steps
;
4869 gfc_expr_list
*tile
= do_clauses
? do_clauses
->tile_list
: clauses
->tile_list
;
4871 /* Both collapsed and tiled loops are lowered the same way. In
4872 OpenACC, those clauses are not compatible, so prioritize the tile
4873 clause, if present. */
4877 for (gfc_expr_list
*el
= tile
; el
; el
= el
->next
)
4881 doacross_steps
= NULL
;
4882 if (clauses
->orderedc
)
4883 collapse
= clauses
->orderedc
;
4887 code
= code
->block
->next
;
4888 gcc_assert (code
->op
== EXEC_DO
);
4890 init
= make_tree_vec (collapse
);
4891 cond
= make_tree_vec (collapse
);
4892 incr
= make_tree_vec (collapse
);
4893 orig_decls
= clauses
->orderedc
? make_tree_vec (collapse
) : NULL_TREE
;
4897 gfc_start_block (&block
);
4901 /* simd schedule modifier is only useful for composite do simd and other
4902 constructs including that, where gfc_trans_omp_do is only called
4903 on the simd construct and DO's clauses are translated elsewhere. */
4904 do_clauses
->sched_simd
= false;
4906 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
4908 for (i
= 0; i
< collapse
; i
++)
4911 int dovar_found
= 0;
4916 gfc_omp_namelist
*n
= NULL
;
4917 if (op
== EXEC_OMP_SIMD
&& collapse
== 1)
4918 for (n
= clauses
->lists
[OMP_LIST_LINEAR
];
4919 n
!= NULL
; n
= n
->next
)
4920 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4925 if (n
== NULL
&& op
!= EXEC_OMP_DISTRIBUTE
)
4926 for (n
= clauses
->lists
[OMP_LIST_LASTPRIVATE
];
4927 n
!= NULL
; n
= n
->next
)
4928 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4934 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
4935 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4942 /* Evaluate all the expressions in the iterator. */
4943 gfc_init_se (&se
, NULL
);
4944 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
4945 gfc_add_block_to_block (pblock
, &se
.pre
);
4947 type
= TREE_TYPE (dovar
);
4948 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
4950 gfc_init_se (&se
, NULL
);
4951 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
4952 gfc_add_block_to_block (pblock
, &se
.pre
);
4953 from
= gfc_evaluate_now (se
.expr
, pblock
);
4955 gfc_init_se (&se
, NULL
);
4956 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
4957 gfc_add_block_to_block (pblock
, &se
.pre
);
4958 to
= gfc_evaluate_now (se
.expr
, pblock
);
4960 gfc_init_se (&se
, NULL
);
4961 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
4962 gfc_add_block_to_block (pblock
, &se
.pre
);
4963 step
= gfc_evaluate_now (se
.expr
, pblock
);
4966 /* Special case simple loops. */
4969 if (integer_onep (step
))
4971 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
4976 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
,
4982 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
4983 /* The condition should not be folded. */
4984 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, simple
> 0
4985 ? LE_EXPR
: GE_EXPR
,
4986 logical_type_node
, dovar
, to
);
4987 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
4989 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
4992 TREE_VEC_ELT (incr
, i
));
4996 /* STEP is not 1 or -1. Use:
4997 for (count = 0; count < (to + step - from) / step; count++)
4999 dovar = from + count * step;
5003 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, step
, from
);
5004 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, to
, tmp
);
5005 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
, tmp
,
5007 tmp
= gfc_evaluate_now (tmp
, pblock
);
5008 count
= gfc_create_var (type
, "count");
5009 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
5010 build_int_cst (type
, 0));
5011 /* The condition should not be folded. */
5012 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, LT_EXPR
,
5015 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
5017 build_int_cst (type
, 1));
5018 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
5019 MODIFY_EXPR
, type
, count
,
5020 TREE_VEC_ELT (incr
, i
));
5022 /* Initialize DOVAR. */
5023 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, count
, step
);
5024 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, from
, tmp
);
5025 dovar_init e
= {dovar
, tmp
};
5026 inits
.safe_push (e
);
5027 if (clauses
->orderedc
)
5029 if (doacross_steps
== NULL
)
5030 vec_safe_grow_cleared (doacross_steps
, clauses
->orderedc
, true);
5031 (*doacross_steps
)[i
] = step
;
5035 TREE_VEC_ELT (orig_decls
, i
) = dovar_decl
;
5037 if (dovar_found
== 3
5038 && op
== EXEC_OMP_SIMD
5042 for (tmp
= omp_clauses
; tmp
; tmp
= OMP_CLAUSE_CHAIN (tmp
))
5043 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_LINEAR
5044 && OMP_CLAUSE_DECL (tmp
) == dovar
)
5046 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
5050 if (!dovar_found
&& op
== EXEC_OMP_SIMD
)
5054 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
5055 OMP_CLAUSE_LINEAR_STEP (tmp
) = step
;
5056 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
5057 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
5058 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
5063 else if (!dovar_found
&& !simple
)
5065 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
5066 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
5067 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
5069 if (dovar_found
> 1)
5076 /* If dovar is lastprivate, but different counter is used,
5077 dovar += step needs to be added to
5078 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
5079 will have the value on entry of the last loop, rather
5080 than value after iterator increment. */
5081 if (clauses
->orderedc
)
5083 if (clauses
->collapse
<= 1 || i
>= clauses
->collapse
)
5086 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5087 type
, count
, build_one_cst (type
));
5088 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
5090 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
5095 tmp
= gfc_evaluate_now (step
, pblock
);
5096 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
5099 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
,
5101 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
5102 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
5103 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
5105 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
5108 else if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LINEAR
5109 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
5111 OMP_CLAUSE_LINEAR_STMT (c
) = tmp
;
5115 if (c
== NULL
&& op
== EXEC_OMP_DO
&& par_clauses
!= NULL
)
5117 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
5118 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
5119 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
5121 tree l
= build_omp_clause (input_location
,
5122 OMP_CLAUSE_LASTPRIVATE
);
5123 if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c
))
5124 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l
) = 1;
5125 OMP_CLAUSE_DECL (l
) = dovar_decl
;
5126 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
5127 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
5129 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
5133 gcc_assert (simple
|| c
!= NULL
);
5137 if (op
!= EXEC_OMP_SIMD
|| dovar_found
== 1)
5138 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
5139 else if (collapse
== 1)
5141 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
5142 OMP_CLAUSE_LINEAR_STEP (tmp
) = build_int_cst (type
, 1);
5143 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
5144 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp
) = 1;
5147 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
5148 OMP_CLAUSE_DECL (tmp
) = count
;
5149 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
5152 if (i
+ 1 < collapse
)
5153 code
= code
->block
->next
;
5156 if (pblock
!= &block
)
5159 gfc_start_block (&block
);
5162 gfc_start_block (&body
);
5164 FOR_EACH_VEC_ELT (inits
, ix
, di
)
5165 gfc_add_modify (&body
, di
->var
, di
->init
);
5168 /* Cycle statement is implemented with a goto. Exit statement must not be
5169 present for this loop. */
5170 cycle_label
= gfc_build_label_decl (NULL_TREE
);
5172 /* Put these labels where they can be found later. */
5174 code
->cycle_label
= cycle_label
;
5175 code
->exit_label
= NULL_TREE
;
5177 /* Main loop body. */
5178 if (clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
])
5180 gcc_assert (code
->block
->next
->next
->op
== EXEC_OMP_SCAN
);
5181 gcc_assert (code
->block
->next
->next
->next
->next
== NULL
);
5182 locus
*cloc
= &code
->block
->next
->next
->loc
;
5183 location_t loc
= gfc_get_location (cloc
);
5185 gfc_code code2
= *code
->block
->next
;
5187 tmp
= gfc_trans_code (&code2
);
5188 tmp
= build2 (OMP_SCAN
, void_type_node
, tmp
, NULL_TREE
);
5189 SET_EXPR_LOCATION (tmp
, loc
);
5190 gfc_add_expr_to_block (&body
, tmp
);
5191 input_location
= loc
;
5192 tree c
= gfc_trans_omp_clauses (&body
,
5193 code
->block
->next
->next
->ext
.omp_clauses
,
5195 code2
= *code
->block
->next
->next
->next
;
5197 tmp
= gfc_trans_code (&code2
);
5198 tmp
= build2 (OMP_SCAN
, void_type_node
, tmp
, c
);
5199 SET_EXPR_LOCATION (tmp
, loc
);
5202 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
5203 gfc_add_expr_to_block (&body
, tmp
);
5205 /* Label for cycle statements (if needed). */
5206 if (TREE_USED (cycle_label
))
5208 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
5209 gfc_add_expr_to_block (&body
, tmp
);
5212 /* End of loop body. */
5215 case EXEC_OMP_SIMD
: stmt
= make_node (OMP_SIMD
); break;
5216 case EXEC_OMP_DO
: stmt
= make_node (OMP_FOR
); break;
5217 case EXEC_OMP_DISTRIBUTE
: stmt
= make_node (OMP_DISTRIBUTE
); break;
5218 case EXEC_OMP_LOOP
: stmt
= make_node (OMP_LOOP
); break;
5219 case EXEC_OMP_TASKLOOP
: stmt
= make_node (OMP_TASKLOOP
); break;
5220 case EXEC_OACC_LOOP
: stmt
= make_node (OACC_LOOP
); break;
5221 default: gcc_unreachable ();
5224 TREE_TYPE (stmt
) = void_type_node
;
5225 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
5226 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
5227 OMP_FOR_INIT (stmt
) = init
;
5228 OMP_FOR_COND (stmt
) = cond
;
5229 OMP_FOR_INCR (stmt
) = incr
;
5231 OMP_FOR_ORIG_DECLS (stmt
) = orig_decls
;
5232 gfc_add_expr_to_block (&block
, stmt
);
5234 vec_free (doacross_steps
);
5235 doacross_steps
= saved_doacross_steps
;
5237 return gfc_finish_block (&block
);
5240 /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
5244 gfc_trans_oacc_combined_directive (gfc_code
*code
)
5246 stmtblock_t block
, *pblock
= NULL
;
5247 gfc_omp_clauses construct_clauses
, loop_clauses
;
5248 tree stmt
, oacc_clauses
= NULL_TREE
;
5249 enum tree_code construct_code
;
5250 location_t loc
= input_location
;
5254 case EXEC_OACC_PARALLEL_LOOP
:
5255 construct_code
= OACC_PARALLEL
;
5257 case EXEC_OACC_KERNELS_LOOP
:
5258 construct_code
= OACC_KERNELS
;
5260 case EXEC_OACC_SERIAL_LOOP
:
5261 construct_code
= OACC_SERIAL
;
5267 gfc_start_block (&block
);
5269 memset (&loop_clauses
, 0, sizeof (loop_clauses
));
5270 if (code
->ext
.omp_clauses
!= NULL
)
5272 memcpy (&construct_clauses
, code
->ext
.omp_clauses
,
5273 sizeof (construct_clauses
));
5274 loop_clauses
.collapse
= construct_clauses
.collapse
;
5275 loop_clauses
.gang
= construct_clauses
.gang
;
5276 loop_clauses
.gang_static
= construct_clauses
.gang_static
;
5277 loop_clauses
.gang_num_expr
= construct_clauses
.gang_num_expr
;
5278 loop_clauses
.gang_static_expr
= construct_clauses
.gang_static_expr
;
5279 loop_clauses
.vector
= construct_clauses
.vector
;
5280 loop_clauses
.vector_expr
= construct_clauses
.vector_expr
;
5281 loop_clauses
.worker
= construct_clauses
.worker
;
5282 loop_clauses
.worker_expr
= construct_clauses
.worker_expr
;
5283 loop_clauses
.seq
= construct_clauses
.seq
;
5284 loop_clauses
.par_auto
= construct_clauses
.par_auto
;
5285 loop_clauses
.independent
= construct_clauses
.independent
;
5286 loop_clauses
.tile_list
= construct_clauses
.tile_list
;
5287 loop_clauses
.lists
[OMP_LIST_PRIVATE
]
5288 = construct_clauses
.lists
[OMP_LIST_PRIVATE
];
5289 loop_clauses
.lists
[OMP_LIST_REDUCTION
]
5290 = construct_clauses
.lists
[OMP_LIST_REDUCTION
];
5291 construct_clauses
.gang
= false;
5292 construct_clauses
.gang_static
= false;
5293 construct_clauses
.gang_num_expr
= NULL
;
5294 construct_clauses
.gang_static_expr
= NULL
;
5295 construct_clauses
.vector
= false;
5296 construct_clauses
.vector_expr
= NULL
;
5297 construct_clauses
.worker
= false;
5298 construct_clauses
.worker_expr
= NULL
;
5299 construct_clauses
.seq
= false;
5300 construct_clauses
.par_auto
= false;
5301 construct_clauses
.independent
= false;
5302 construct_clauses
.independent
= false;
5303 construct_clauses
.tile_list
= NULL
;
5304 construct_clauses
.lists
[OMP_LIST_PRIVATE
] = NULL
;
5305 if (construct_code
== OACC_KERNELS
)
5306 construct_clauses
.lists
[OMP_LIST_REDUCTION
] = NULL
;
5307 oacc_clauses
= gfc_trans_omp_clauses (&block
, &construct_clauses
,
5308 code
->loc
, false, true);
5310 if (!loop_clauses
.seq
)
5314 stmt
= gfc_trans_omp_do (code
, EXEC_OACC_LOOP
, pblock
, &loop_clauses
, NULL
);
5315 protected_set_expr_location (stmt
, loc
);
5316 if (TREE_CODE (stmt
) != BIND_EXPR
)
5317 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5320 stmt
= build2_loc (loc
, construct_code
, void_type_node
, stmt
, oacc_clauses
);
5321 gfc_add_expr_to_block (&block
, stmt
);
5322 return gfc_finish_block (&block
);
5326 gfc_trans_omp_depobj (gfc_code
*code
)
5330 gfc_init_se (&se
, NULL
);
5331 gfc_init_block (&block
);
5332 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->depobj
);
5333 gcc_assert (se
.pre
.head
== NULL
&& se
.post
.head
== NULL
);
5334 tree depobj
= se
.expr
;
5335 location_t loc
= EXPR_LOCATION (depobj
);
5336 if (!POINTER_TYPE_P (TREE_TYPE (depobj
)))
5337 depobj
= gfc_build_addr_expr (NULL
, depobj
);
5338 depobj
= fold_convert (build_pointer_type_for_mode (ptr_type_node
,
5339 TYPE_MODE (ptr_type_node
),
5341 gfc_omp_namelist
*n
= code
->ext
.omp_clauses
->lists
[OMP_LIST_DEPEND
];
5346 var
= gfc_convert_expr_to_tree (&block
, n
->expr
);
5348 var
= gfc_get_symbol_decl (n
->sym
);
5349 if (!POINTER_TYPE_P (TREE_TYPE (var
)))
5350 var
= gfc_build_addr_expr (NULL
, var
);
5351 depobj
= save_expr (depobj
);
5352 tree r
= build_fold_indirect_ref_loc (loc
, depobj
);
5353 gfc_add_expr_to_block (&block
,
5354 build2 (MODIFY_EXPR
, void_type_node
, r
, var
));
5357 /* Only one may be set. */
5358 gcc_assert (((int)(n
!= NULL
) + (int)(code
->ext
.omp_clauses
->destroy
)
5359 + (int)(code
->ext
.omp_clauses
->depobj_update
!= OMP_DEPEND_UNSET
))
5361 int k
= -1; /* omp_clauses->destroy */
5362 if (!code
->ext
.omp_clauses
->destroy
)
5363 switch (code
->ext
.omp_clauses
->depobj_update
!= OMP_DEPEND_UNSET
5364 ? code
->ext
.omp_clauses
->depobj_update
: n
->u
.depend_op
)
5366 case OMP_DEPEND_IN
: k
= GOMP_DEPEND_IN
; break;
5367 case OMP_DEPEND_OUT
: k
= GOMP_DEPEND_OUT
; break;
5368 case OMP_DEPEND_INOUT
: k
= GOMP_DEPEND_INOUT
; break;
5369 case OMP_DEPEND_MUTEXINOUTSET
: k
= GOMP_DEPEND_MUTEXINOUTSET
; break;
5370 default: gcc_unreachable ();
5372 tree t
= build_int_cst (ptr_type_node
, k
);
5373 depobj
= build2_loc (loc
, POINTER_PLUS_EXPR
, TREE_TYPE (depobj
), depobj
,
5374 TYPE_SIZE_UNIT (ptr_type_node
));
5375 depobj
= build_fold_indirect_ref_loc (loc
, depobj
);
5376 gfc_add_expr_to_block (&block
, build2 (MODIFY_EXPR
, void_type_node
, depobj
, t
));
5378 return gfc_finish_block (&block
);
5382 gfc_trans_omp_error (gfc_code
*code
)
5387 bool fatal
= code
->ext
.omp_clauses
->severity
== OMP_SEVERITY_FATAL
;
5388 tree fndecl
= builtin_decl_explicit (fatal
? BUILT_IN_GOMP_ERROR
5389 : BUILT_IN_GOMP_WARNING
);
5390 gfc_start_block (&block
);
5391 gfc_init_se (&se
, NULL
);
5392 if (!code
->ext
.omp_clauses
->message
)
5394 message
= null_pointer_node
;
5395 len
= build_int_cst (size_type_node
, 0);
5399 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->message
);
5401 if (!POINTER_TYPE_P (TREE_TYPE (message
)))
5402 /* To ensure an ARRAY_TYPE is not passed as such. */
5403 message
= gfc_build_addr_expr (NULL
, message
);
5404 len
= se
.string_length
;
5406 gfc_add_block_to_block (&block
, &se
.pre
);
5407 gfc_add_expr_to_block (&block
, build_call_expr_loc (input_location
, fndecl
,
5409 gfc_add_block_to_block (&block
, &se
.post
);
5410 return gfc_finish_block (&block
);
5414 gfc_trans_omp_flush (gfc_code
*code
)
5417 if (!code
->ext
.omp_clauses
5418 || code
->ext
.omp_clauses
->memorder
== OMP_MEMORDER_UNSET
5419 || code
->ext
.omp_clauses
->memorder
== OMP_MEMORDER_SEQ_CST
)
5421 call
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
5422 call
= build_call_expr_loc (input_location
, call
, 0);
5426 enum memmodel mo
= MEMMODEL_LAST
;
5427 switch (code
->ext
.omp_clauses
->memorder
)
5429 case OMP_MEMORDER_ACQ_REL
: mo
= MEMMODEL_ACQ_REL
; break;
5430 case OMP_MEMORDER_RELEASE
: mo
= MEMMODEL_RELEASE
; break;
5431 case OMP_MEMORDER_ACQUIRE
: mo
= MEMMODEL_ACQUIRE
; break;
5432 default: gcc_unreachable (); break;
5434 call
= builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE
);
5435 call
= build_call_expr_loc (input_location
, call
, 1,
5436 build_int_cst (integer_type_node
, mo
));
5442 gfc_trans_omp_master (gfc_code
*code
)
5444 tree stmt
= gfc_trans_code (code
->block
->next
);
5445 if (IS_EMPTY_STMT (stmt
))
5447 return build1_v (OMP_MASTER
, stmt
);
5451 gfc_trans_omp_masked (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5454 tree body
= gfc_trans_code (code
->block
->next
);
5455 if (IS_EMPTY_STMT (body
))
5458 clauses
= code
->ext
.omp_clauses
;
5459 gfc_start_block (&block
);
5460 tree omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
5461 tree stmt
= make_node (OMP_MASKED
);
5462 TREE_TYPE (stmt
) = void_type_node
;
5463 OMP_MASKED_BODY (stmt
) = body
;
5464 OMP_MASKED_CLAUSES (stmt
) = omp_clauses
;
5465 gfc_add_expr_to_block (&block
, stmt
);
5466 return gfc_finish_block (&block
);
5471 gfc_trans_omp_ordered (gfc_code
*code
)
5475 if (!code
->ext
.omp_clauses
->simd
)
5476 return gfc_trans_code (code
->block
? code
->block
->next
: NULL
);
5477 code
->ext
.omp_clauses
->threads
= 0;
5479 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, code
->ext
.omp_clauses
,
5481 return build2_loc (input_location
, OMP_ORDERED
, void_type_node
,
5482 code
->block
? gfc_trans_code (code
->block
->next
)
5483 : NULL_TREE
, omp_clauses
);
5487 gfc_trans_omp_parallel (gfc_code
*code
)
5490 tree stmt
, omp_clauses
;
5492 gfc_start_block (&block
);
5493 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5496 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5497 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5498 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5500 gfc_add_expr_to_block (&block
, stmt
);
5501 return gfc_finish_block (&block
);
5508 GFC_OMP_SPLIT_PARALLEL
,
5509 GFC_OMP_SPLIT_DISTRIBUTE
,
5510 GFC_OMP_SPLIT_TEAMS
,
5511 GFC_OMP_SPLIT_TARGET
,
5512 GFC_OMP_SPLIT_TASKLOOP
,
5513 GFC_OMP_SPLIT_MASKED
,
5519 GFC_OMP_MASK_SIMD
= (1 << GFC_OMP_SPLIT_SIMD
),
5520 GFC_OMP_MASK_DO
= (1 << GFC_OMP_SPLIT_DO
),
5521 GFC_OMP_MASK_PARALLEL
= (1 << GFC_OMP_SPLIT_PARALLEL
),
5522 GFC_OMP_MASK_DISTRIBUTE
= (1 << GFC_OMP_SPLIT_DISTRIBUTE
),
5523 GFC_OMP_MASK_TEAMS
= (1 << GFC_OMP_SPLIT_TEAMS
),
5524 GFC_OMP_MASK_TARGET
= (1 << GFC_OMP_SPLIT_TARGET
),
5525 GFC_OMP_MASK_TASKLOOP
= (1 << GFC_OMP_SPLIT_TASKLOOP
),
5526 GFC_OMP_MASK_MASKED
= (1 << GFC_OMP_SPLIT_MASKED
)
5529 /* If a var is in lastprivate/firstprivate/reduction but not in a
5530 data mapping/sharing clause, add it to 'map(tofrom:' if is_target
5531 and to 'shared' otherwise. */
5533 gfc_add_clause_implicitly (gfc_omp_clauses
*clauses_out
,
5534 gfc_omp_clauses
*clauses_in
,
5535 bool is_target
, bool is_parallel_do
)
5537 int clauselist_to_add
= is_target
? OMP_LIST_MAP
: OMP_LIST_SHARED
;
5538 gfc_omp_namelist
*tail
= NULL
;
5539 for (int i
= 0; i
< 5; ++i
)
5541 gfc_omp_namelist
*n
;
5544 case 0: n
= clauses_in
->lists
[OMP_LIST_FIRSTPRIVATE
]; break;
5545 case 1: n
= clauses_in
->lists
[OMP_LIST_LASTPRIVATE
]; break;
5546 case 2: n
= clauses_in
->lists
[OMP_LIST_REDUCTION
]; break;
5547 case 3: n
= clauses_in
->lists
[OMP_LIST_REDUCTION_INSCAN
]; break;
5548 case 4: n
= clauses_in
->lists
[OMP_LIST_REDUCTION_TASK
]; break;
5549 default: gcc_unreachable ();
5551 for (; n
!= NULL
; n
= n
->next
)
5553 gfc_omp_namelist
*n2
, **n_firstp
= NULL
, **n_lastp
= NULL
;
5554 for (int j
= 0; j
< 6; ++j
)
5556 gfc_omp_namelist
**n2ref
= NULL
, *prev2
= NULL
;
5560 n2ref
= &clauses_out
->lists
[clauselist_to_add
];
5563 n2ref
= &clauses_out
->lists
[OMP_LIST_FIRSTPRIVATE
];
5567 n2ref
= &clauses_in
->lists
[OMP_LIST_LASTPRIVATE
];
5569 n2ref
= &clauses_out
->lists
[OMP_LIST_LASTPRIVATE
];
5571 case 3: n2ref
= &clauses_out
->lists
[OMP_LIST_REDUCTION
]; break;
5573 n2ref
= &clauses_out
->lists
[OMP_LIST_REDUCTION_INSCAN
];
5576 n2ref
= &clauses_out
->lists
[OMP_LIST_REDUCTION_TASK
];
5578 default: gcc_unreachable ();
5580 for (n2
= *n2ref
; n2
!= NULL
; prev2
= n2
, n2
= n2
->next
)
5581 if (n2
->sym
== n
->sym
)
5585 if (j
== 0 /* clauselist_to_add */)
5586 break; /* Already present. */
5587 if (j
== 1 /* OMP_LIST_FIRSTPRIVATE */)
5589 n_firstp
= prev2
? &prev2
->next
: n2ref
;
5592 if (j
== 2 /* OMP_LIST_LASTPRIVATE */)
5594 n_lastp
= prev2
? &prev2
->next
: n2ref
;
5600 if (n_firstp
&& n_lastp
)
5602 /* For parallel do, GCC puts firstprivatee/lastprivate
5606 *n_firstp
= (*n_firstp
)->next
;
5608 *n_lastp
= (*n_lastp
)->next
;
5610 else if (is_target
&& n_lastp
)
5612 else if (n2
|| n_firstp
|| n_lastp
)
5614 if (clauses_out
->lists
[clauselist_to_add
]
5615 && (clauses_out
->lists
[clauselist_to_add
]
5616 == clauses_in
->lists
[clauselist_to_add
]))
5618 gfc_omp_namelist
*p
= NULL
;
5619 for (n2
= clauses_in
->lists
[clauselist_to_add
]; n2
; n2
= n2
->next
)
5623 p
->next
= gfc_get_omp_namelist ();
5628 p
= gfc_get_omp_namelist ();
5629 clauses_out
->lists
[clauselist_to_add
] = p
;
5636 tail
= clauses_out
->lists
[clauselist_to_add
];
5637 for (; tail
&& tail
->next
; tail
= tail
->next
)
5640 n2
= gfc_get_omp_namelist ();
5641 n2
->where
= n
->where
;
5644 n2
->u
.map_op
= OMP_MAP_TOFROM
;
5651 clauses_out
->lists
[clauselist_to_add
] = n2
;
5657 gfc_free_split_omp_clauses (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
5659 for (int i
= 0; i
< GFC_OMP_SPLIT_NUM
; ++i
)
5660 for (int j
= 0; j
< OMP_LIST_NUM
; ++j
)
5661 if (clausesa
[i
].lists
[j
] && clausesa
[i
].lists
[j
] != code
->ext
.omp_clauses
->lists
[j
])
5662 for (gfc_omp_namelist
*n
= clausesa
[i
].lists
[j
]; n
;)
5664 gfc_omp_namelist
*p
= n
;
5671 gfc_split_omp_clauses (gfc_code
*code
,
5672 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
])
5674 int mask
= 0, innermost
= 0;
5675 bool is_loop
= false;
5676 memset (clausesa
, 0, GFC_OMP_SPLIT_NUM
* sizeof (gfc_omp_clauses
));
5679 case EXEC_OMP_DISTRIBUTE
:
5680 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
5682 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5683 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
5684 innermost
= GFC_OMP_SPLIT_DO
;
5686 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5687 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
5688 | GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
5689 innermost
= GFC_OMP_SPLIT_SIMD
;
5691 case EXEC_OMP_DISTRIBUTE_SIMD
:
5692 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
5693 innermost
= GFC_OMP_SPLIT_SIMD
;
5697 innermost
= GFC_OMP_SPLIT_DO
;
5699 case EXEC_OMP_DO_SIMD
:
5700 mask
= GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
5701 innermost
= GFC_OMP_SPLIT_SIMD
;
5703 case EXEC_OMP_PARALLEL
:
5704 innermost
= GFC_OMP_SPLIT_PARALLEL
;
5706 case EXEC_OMP_PARALLEL_DO
:
5707 case EXEC_OMP_PARALLEL_LOOP
:
5708 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
5709 innermost
= GFC_OMP_SPLIT_DO
;
5711 case EXEC_OMP_PARALLEL_DO_SIMD
:
5712 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
5713 innermost
= GFC_OMP_SPLIT_SIMD
;
5715 case EXEC_OMP_PARALLEL_MASKED
:
5716 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_MASKED
;
5717 innermost
= GFC_OMP_SPLIT_MASKED
;
5719 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
5720 mask
= (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_MASKED
5721 | GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
);
5722 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
5724 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
5725 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
5726 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
5728 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
5729 mask
= (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_MASKED
5730 | GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
);
5731 innermost
= GFC_OMP_SPLIT_SIMD
;
5733 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
5734 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
5735 innermost
= GFC_OMP_SPLIT_SIMD
;
5738 innermost
= GFC_OMP_SPLIT_SIMD
;
5740 case EXEC_OMP_TARGET
:
5741 innermost
= GFC_OMP_SPLIT_TARGET
;
5743 case EXEC_OMP_TARGET_PARALLEL
:
5744 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
;
5745 innermost
= GFC_OMP_SPLIT_PARALLEL
;
5747 case EXEC_OMP_TARGET_PARALLEL_DO
:
5748 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
5749 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
5750 innermost
= GFC_OMP_SPLIT_DO
;
5752 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5753 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
5754 | GFC_OMP_MASK_SIMD
;
5755 innermost
= GFC_OMP_SPLIT_SIMD
;
5757 case EXEC_OMP_TARGET_SIMD
:
5758 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_SIMD
;
5759 innermost
= GFC_OMP_SPLIT_SIMD
;
5761 case EXEC_OMP_TARGET_TEAMS
:
5762 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
;
5763 innermost
= GFC_OMP_SPLIT_TEAMS
;
5765 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5766 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
5767 | GFC_OMP_MASK_DISTRIBUTE
;
5768 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
5770 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5771 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
5772 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
5773 innermost
= GFC_OMP_SPLIT_DO
;
5775 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5776 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
5777 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
5778 innermost
= GFC_OMP_SPLIT_SIMD
;
5780 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5781 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
5782 | GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
5783 innermost
= GFC_OMP_SPLIT_SIMD
;
5785 case EXEC_OMP_TARGET_TEAMS_LOOP
:
5786 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DO
;
5787 innermost
= GFC_OMP_SPLIT_DO
;
5789 case EXEC_OMP_MASKED_TASKLOOP
:
5790 mask
= GFC_OMP_SPLIT_MASKED
| GFC_OMP_SPLIT_TASKLOOP
;
5791 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
5793 case EXEC_OMP_MASTER_TASKLOOP
:
5794 case EXEC_OMP_TASKLOOP
:
5795 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
5797 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
5798 mask
= GFC_OMP_MASK_MASKED
| GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
5799 innermost
= GFC_OMP_SPLIT_SIMD
;
5801 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
5802 case EXEC_OMP_TASKLOOP_SIMD
:
5803 mask
= GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
5804 innermost
= GFC_OMP_SPLIT_SIMD
;
5806 case EXEC_OMP_TEAMS
:
5807 innermost
= GFC_OMP_SPLIT_TEAMS
;
5809 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5810 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
;
5811 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
5813 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5814 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
5815 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
5816 innermost
= GFC_OMP_SPLIT_DO
;
5818 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5819 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
5820 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
5821 innermost
= GFC_OMP_SPLIT_SIMD
;
5823 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5824 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
5825 innermost
= GFC_OMP_SPLIT_SIMD
;
5827 case EXEC_OMP_TEAMS_LOOP
:
5828 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DO
;
5829 innermost
= GFC_OMP_SPLIT_DO
;
5836 clausesa
[innermost
] = *code
->ext
.omp_clauses
;
5839 /* Loops are similar to DO but still a bit different. */
5843 case EXEC_OMP_PARALLEL_LOOP
:
5844 case EXEC_OMP_TEAMS_LOOP
:
5845 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
5846 case EXEC_OMP_TARGET_TEAMS_LOOP
:
5851 if (code
->ext
.omp_clauses
!= NULL
)
5853 if (mask
& GFC_OMP_MASK_TARGET
)
5855 /* First the clauses that are unique to some constructs. */
5856 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_MAP
]
5857 = code
->ext
.omp_clauses
->lists
[OMP_LIST_MAP
];
5858 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_IS_DEVICE_PTR
]
5859 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IS_DEVICE_PTR
];
5860 clausesa
[GFC_OMP_SPLIT_TARGET
].device
5861 = code
->ext
.omp_clauses
->device
;
5862 for (int i
= 0; i
< OMP_DEFAULTMAP_CAT_NUM
; i
++)
5863 clausesa
[GFC_OMP_SPLIT_TARGET
].defaultmap
[i
]
5864 = code
->ext
.omp_clauses
->defaultmap
[i
];
5865 clausesa
[GFC_OMP_SPLIT_TARGET
].if_exprs
[OMP_IF_TARGET
]
5866 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TARGET
];
5867 /* And this is copied to all. */
5868 clausesa
[GFC_OMP_SPLIT_TARGET
].if_expr
5869 = code
->ext
.omp_clauses
->if_expr
;
5871 if (mask
& GFC_OMP_MASK_TEAMS
)
5873 /* First the clauses that are unique to some constructs. */
5874 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
5875 = code
->ext
.omp_clauses
->num_teams
;
5876 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
5877 = code
->ext
.omp_clauses
->thread_limit
;
5878 /* Shared and default clauses are allowed on parallel, teams
5880 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_SHARED
]
5881 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5882 clausesa
[GFC_OMP_SPLIT_TEAMS
].default_sharing
5883 = code
->ext
.omp_clauses
->default_sharing
;
5885 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5887 /* First the clauses that are unique to some constructs. */
5888 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_sched_kind
5889 = code
->ext
.omp_clauses
->dist_sched_kind
;
5890 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_chunk_size
5891 = code
->ext
.omp_clauses
->dist_chunk_size
;
5892 /* Duplicate collapse. */
5893 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].collapse
5894 = code
->ext
.omp_clauses
->collapse
;
5895 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].order_concurrent
5896 = code
->ext
.omp_clauses
->order_concurrent
;
5897 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].order_unconstrained
5898 = code
->ext
.omp_clauses
->order_unconstrained
;
5899 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].order_reproducible
5900 = code
->ext
.omp_clauses
->order_reproducible
;
5902 if (mask
& GFC_OMP_MASK_PARALLEL
)
5904 /* First the clauses that are unique to some constructs. */
5905 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_COPYIN
]
5906 = code
->ext
.omp_clauses
->lists
[OMP_LIST_COPYIN
];
5907 clausesa
[GFC_OMP_SPLIT_PARALLEL
].num_threads
5908 = code
->ext
.omp_clauses
->num_threads
;
5909 clausesa
[GFC_OMP_SPLIT_PARALLEL
].proc_bind
5910 = code
->ext
.omp_clauses
->proc_bind
;
5911 /* Shared and default clauses are allowed on parallel, teams
5913 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_SHARED
]
5914 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5915 clausesa
[GFC_OMP_SPLIT_PARALLEL
].default_sharing
5916 = code
->ext
.omp_clauses
->default_sharing
;
5917 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_exprs
[OMP_IF_PARALLEL
]
5918 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_PARALLEL
];
5919 /* And this is copied to all. */
5920 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
5921 = code
->ext
.omp_clauses
->if_expr
;
5923 if (mask
& GFC_OMP_MASK_MASKED
)
5924 clausesa
[GFC_OMP_SPLIT_MASKED
].filter
= code
->ext
.omp_clauses
->filter
;
5925 if ((mask
& GFC_OMP_MASK_DO
) && !is_loop
)
5927 /* First the clauses that are unique to some constructs. */
5928 clausesa
[GFC_OMP_SPLIT_DO
].ordered
5929 = code
->ext
.omp_clauses
->ordered
;
5930 clausesa
[GFC_OMP_SPLIT_DO
].orderedc
5931 = code
->ext
.omp_clauses
->orderedc
;
5932 clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
5933 = code
->ext
.omp_clauses
->sched_kind
;
5934 if (innermost
== GFC_OMP_SPLIT_SIMD
)
5935 clausesa
[GFC_OMP_SPLIT_DO
].sched_simd
5936 = code
->ext
.omp_clauses
->sched_simd
;
5937 clausesa
[GFC_OMP_SPLIT_DO
].sched_monotonic
5938 = code
->ext
.omp_clauses
->sched_monotonic
;
5939 clausesa
[GFC_OMP_SPLIT_DO
].sched_nonmonotonic
5940 = code
->ext
.omp_clauses
->sched_nonmonotonic
;
5941 clausesa
[GFC_OMP_SPLIT_DO
].chunk_size
5942 = code
->ext
.omp_clauses
->chunk_size
;
5943 clausesa
[GFC_OMP_SPLIT_DO
].nowait
5944 = code
->ext
.omp_clauses
->nowait
;
5946 if (mask
& GFC_OMP_MASK_DO
)
5948 clausesa
[GFC_OMP_SPLIT_DO
].bind
5949 = code
->ext
.omp_clauses
->bind
;
5950 /* Duplicate collapse. */
5951 clausesa
[GFC_OMP_SPLIT_DO
].collapse
5952 = code
->ext
.omp_clauses
->collapse
;
5953 clausesa
[GFC_OMP_SPLIT_DO
].order_concurrent
5954 = code
->ext
.omp_clauses
->order_concurrent
;
5955 clausesa
[GFC_OMP_SPLIT_DO
].order_unconstrained
5956 = code
->ext
.omp_clauses
->order_unconstrained
;
5957 clausesa
[GFC_OMP_SPLIT_DO
].order_reproducible
5958 = code
->ext
.omp_clauses
->order_reproducible
;
5960 if (mask
& GFC_OMP_MASK_SIMD
)
5962 clausesa
[GFC_OMP_SPLIT_SIMD
].safelen_expr
5963 = code
->ext
.omp_clauses
->safelen_expr
;
5964 clausesa
[GFC_OMP_SPLIT_SIMD
].simdlen_expr
5965 = code
->ext
.omp_clauses
->simdlen_expr
;
5966 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_ALIGNED
]
5967 = code
->ext
.omp_clauses
->lists
[OMP_LIST_ALIGNED
];
5968 /* Duplicate collapse. */
5969 clausesa
[GFC_OMP_SPLIT_SIMD
].collapse
5970 = code
->ext
.omp_clauses
->collapse
;
5971 clausesa
[GFC_OMP_SPLIT_SIMD
].if_exprs
[OMP_IF_SIMD
]
5972 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_SIMD
];
5973 clausesa
[GFC_OMP_SPLIT_SIMD
].order_concurrent
5974 = code
->ext
.omp_clauses
->order_concurrent
;
5975 clausesa
[GFC_OMP_SPLIT_SIMD
].order_unconstrained
5976 = code
->ext
.omp_clauses
->order_unconstrained
;
5977 clausesa
[GFC_OMP_SPLIT_SIMD
].order_reproducible
5978 = code
->ext
.omp_clauses
->order_reproducible
;
5979 /* And this is copied to all. */
5980 clausesa
[GFC_OMP_SPLIT_SIMD
].if_expr
5981 = code
->ext
.omp_clauses
->if_expr
;
5983 if (mask
& GFC_OMP_MASK_TASKLOOP
)
5985 /* First the clauses that are unique to some constructs. */
5986 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].nogroup
5987 = code
->ext
.omp_clauses
->nogroup
;
5988 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].grainsize
5989 = code
->ext
.omp_clauses
->grainsize
;
5990 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].grainsize_strict
5991 = code
->ext
.omp_clauses
->grainsize_strict
;
5992 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].num_tasks
5993 = code
->ext
.omp_clauses
->num_tasks
;
5994 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].num_tasks_strict
5995 = code
->ext
.omp_clauses
->num_tasks_strict
;
5996 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].priority
5997 = code
->ext
.omp_clauses
->priority
;
5998 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].final_expr
5999 = code
->ext
.omp_clauses
->final_expr
;
6000 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].untied
6001 = code
->ext
.omp_clauses
->untied
;
6002 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].mergeable
6003 = code
->ext
.omp_clauses
->mergeable
;
6004 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_exprs
[OMP_IF_TASKLOOP
]
6005 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TASKLOOP
];
6006 /* And this is copied to all. */
6007 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_expr
6008 = code
->ext
.omp_clauses
->if_expr
;
6009 /* Shared and default clauses are allowed on parallel, teams
6011 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_SHARED
]
6012 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
6013 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].default_sharing
6014 = code
->ext
.omp_clauses
->default_sharing
;
6015 /* Duplicate collapse. */
6016 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].collapse
6017 = code
->ext
.omp_clauses
->collapse
;
6019 /* Private clause is supported on all constructs but master/masked,
6020 it is enough to put it on the innermost one except for master/masked. For
6021 !$ omp parallel do put it on parallel though,
6022 as that's what we did for OpenMP 3.1. */
6023 clausesa
[((innermost
== GFC_OMP_SPLIT_DO
&& !is_loop
)
6024 || code
->op
== EXEC_OMP_PARALLEL_MASTER
6025 || code
->op
== EXEC_OMP_PARALLEL_MASKED
)
6026 ? (int) GFC_OMP_SPLIT_PARALLEL
6027 : innermost
].lists
[OMP_LIST_PRIVATE
]
6028 = code
->ext
.omp_clauses
->lists
[OMP_LIST_PRIVATE
];
6029 /* Firstprivate clause is supported on all constructs but
6030 simd and masked/master. Put it on the outermost of those and duplicate
6031 on parallel and teams. */
6032 if (mask
& GFC_OMP_MASK_TARGET
)
6033 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_FIRSTPRIVATE
]
6034 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6035 if (mask
& GFC_OMP_MASK_TEAMS
)
6036 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_FIRSTPRIVATE
]
6037 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6038 else if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
6039 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_FIRSTPRIVATE
]
6040 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6041 if (mask
& GFC_OMP_MASK_TASKLOOP
)
6042 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_FIRSTPRIVATE
]
6043 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6044 if ((mask
& GFC_OMP_MASK_PARALLEL
)
6045 && !(mask
& GFC_OMP_MASK_TASKLOOP
))
6046 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_FIRSTPRIVATE
]
6047 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6048 else if ((mask
& GFC_OMP_MASK_DO
) && !is_loop
)
6049 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_FIRSTPRIVATE
]
6050 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
6051 /* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
6052 In parallel do{, simd} we actually want to put it on
6053 parallel rather than do. */
6054 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
6055 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_LASTPRIVATE
]
6056 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
6057 if (mask
& GFC_OMP_MASK_TASKLOOP
)
6058 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_LASTPRIVATE
]
6059 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
6060 if ((mask
& GFC_OMP_MASK_PARALLEL
) && !is_loop
6061 && !(mask
& GFC_OMP_MASK_TASKLOOP
))
6062 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_LASTPRIVATE
]
6063 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
6064 else if (mask
& GFC_OMP_MASK_DO
)
6065 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_LASTPRIVATE
]
6066 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
6067 if (mask
& GFC_OMP_MASK_SIMD
)
6068 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LASTPRIVATE
]
6069 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
6070 /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop.
6071 Duplicate it on all of them, but
6072 - omit on do if parallel is present;
6073 - omit on task and parallel if loop is present;
6074 additionally, inscan applies to do/simd only. */
6075 for (int i
= OMP_LIST_REDUCTION
; i
<= OMP_LIST_REDUCTION_TASK
; i
++)
6077 if (mask
& GFC_OMP_MASK_TASKLOOP
6078 && i
!= OMP_LIST_REDUCTION_INSCAN
)
6079 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[i
]
6080 = code
->ext
.omp_clauses
->lists
[i
];
6081 if (mask
& GFC_OMP_MASK_TEAMS
6082 && i
!= OMP_LIST_REDUCTION_INSCAN
6084 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[i
]
6085 = code
->ext
.omp_clauses
->lists
[i
];
6086 if (mask
& GFC_OMP_MASK_PARALLEL
6087 && i
!= OMP_LIST_REDUCTION_INSCAN
6088 && !(mask
& GFC_OMP_MASK_TASKLOOP
)
6090 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[i
]
6091 = code
->ext
.omp_clauses
->lists
[i
];
6092 else if (mask
& GFC_OMP_MASK_DO
)
6093 clausesa
[GFC_OMP_SPLIT_DO
].lists
[i
]
6094 = code
->ext
.omp_clauses
->lists
[i
];
6095 if (mask
& GFC_OMP_MASK_SIMD
)
6096 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[i
]
6097 = code
->ext
.omp_clauses
->lists
[i
];
6099 if (mask
& GFC_OMP_MASK_TARGET
)
6100 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_IN_REDUCTION
]
6101 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IN_REDUCTION
];
6102 if (mask
& GFC_OMP_MASK_TASKLOOP
)
6103 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_IN_REDUCTION
]
6104 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IN_REDUCTION
];
6105 /* Linear clause is supported on do and simd,
6106 put it on the innermost one. */
6107 clausesa
[innermost
].lists
[OMP_LIST_LINEAR
]
6108 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LINEAR
];
6110 /* Propagate firstprivate/lastprivate/reduction vars to
6111 shared (parallel, teams) and map-tofrom (target). */
6112 if (mask
& GFC_OMP_MASK_TARGET
)
6113 gfc_add_clause_implicitly (&clausesa
[GFC_OMP_SPLIT_TARGET
],
6114 code
->ext
.omp_clauses
, true, false);
6115 if ((mask
& GFC_OMP_MASK_PARALLEL
) && innermost
!= GFC_OMP_MASK_PARALLEL
)
6116 gfc_add_clause_implicitly (&clausesa
[GFC_OMP_SPLIT_PARALLEL
],
6117 code
->ext
.omp_clauses
, false,
6118 mask
& GFC_OMP_MASK_DO
);
6119 if (mask
& GFC_OMP_MASK_TEAMS
&& innermost
!= GFC_OMP_MASK_TEAMS
)
6120 gfc_add_clause_implicitly (&clausesa
[GFC_OMP_SPLIT_TEAMS
],
6121 code
->ext
.omp_clauses
, false, false);
6122 if (((mask
& (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
6123 == (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
6125 clausesa
[GFC_OMP_SPLIT_DO
].nowait
= true;
6129 gfc_trans_omp_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
6130 gfc_omp_clauses
*clausesa
, tree omp_clauses
)
6133 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
6134 tree stmt
, body
, omp_do_clauses
= NULL_TREE
;
6135 bool free_clausesa
= false;
6138 gfc_start_block (&block
);
6140 gfc_init_block (&block
);
6142 if (clausesa
== NULL
)
6144 clausesa
= clausesa_buf
;
6145 gfc_split_omp_clauses (code
, clausesa
);
6146 free_clausesa
= true;
6150 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DO
], code
->loc
);
6151 body
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, pblock
? pblock
: &block
,
6152 &clausesa
[GFC_OMP_SPLIT_SIMD
], omp_clauses
);
6155 if (TREE_CODE (body
) != BIND_EXPR
)
6156 body
= build3_v (BIND_EXPR
, NULL
, body
, poplevel (1, 0));
6160 else if (TREE_CODE (body
) != BIND_EXPR
)
6161 body
= build3_v (BIND_EXPR
, NULL
, body
, NULL_TREE
);
6164 stmt
= make_node (OMP_FOR
);
6165 TREE_TYPE (stmt
) = void_type_node
;
6166 OMP_FOR_BODY (stmt
) = body
;
6167 OMP_FOR_CLAUSES (stmt
) = omp_do_clauses
;
6171 gfc_add_expr_to_block (&block
, stmt
);
6173 gfc_free_split_omp_clauses (code
, clausesa
);
6174 return gfc_finish_block (&block
);
6178 gfc_trans_omp_parallel_do (gfc_code
*code
, bool is_loop
, stmtblock_t
*pblock
,
6179 gfc_omp_clauses
*clausesa
)
6181 stmtblock_t block
, *new_pblock
= pblock
;
6182 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
6183 tree stmt
, omp_clauses
= NULL_TREE
;
6184 bool free_clausesa
= false;
6187 gfc_start_block (&block
);
6189 gfc_init_block (&block
);
6191 if (clausesa
== NULL
)
6193 clausesa
= clausesa_buf
;
6194 gfc_split_omp_clauses (code
, clausesa
);
6195 free_clausesa
= true;
6198 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
6202 if (!clausesa
[GFC_OMP_SPLIT_DO
].ordered
6203 && clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
!= OMP_SCHED_STATIC
)
6204 new_pblock
= &block
;
6208 stmt
= gfc_trans_omp_do (code
, is_loop
? EXEC_OMP_LOOP
: EXEC_OMP_DO
,
6209 new_pblock
, &clausesa
[GFC_OMP_SPLIT_DO
],
6213 if (TREE_CODE (stmt
) != BIND_EXPR
)
6214 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6218 else if (TREE_CODE (stmt
) != BIND_EXPR
)
6219 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
6220 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_PARALLEL
,
6221 void_type_node
, stmt
, omp_clauses
);
6222 OMP_PARALLEL_COMBINED (stmt
) = 1;
6223 gfc_add_expr_to_block (&block
, stmt
);
6225 gfc_free_split_omp_clauses (code
, clausesa
);
6226 return gfc_finish_block (&block
);
6230 gfc_trans_omp_parallel_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
6231 gfc_omp_clauses
*clausesa
)
6234 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
6235 tree stmt
, omp_clauses
= NULL_TREE
;
6236 bool free_clausesa
= false;
6239 gfc_start_block (&block
);
6241 gfc_init_block (&block
);
6243 if (clausesa
== NULL
)
6245 clausesa
= clausesa_buf
;
6246 gfc_split_omp_clauses (code
, clausesa
);
6247 free_clausesa
= true;
6251 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
6255 stmt
= gfc_trans_omp_do_simd (code
, pblock
, clausesa
, omp_clauses
);
6258 if (TREE_CODE (stmt
) != BIND_EXPR
)
6259 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6263 else if (TREE_CODE (stmt
) != BIND_EXPR
)
6264 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
6267 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_PARALLEL
,
6268 void_type_node
, stmt
, omp_clauses
);
6269 OMP_PARALLEL_COMBINED (stmt
) = 1;
6271 gfc_add_expr_to_block (&block
, stmt
);
6273 gfc_free_split_omp_clauses (code
, clausesa
);
6274 return gfc_finish_block (&block
);
6278 gfc_trans_omp_parallel_sections (gfc_code
*code
)
6281 gfc_omp_clauses section_clauses
;
6282 tree stmt
, omp_clauses
;
6284 memset (§ion_clauses
, 0, sizeof (section_clauses
));
6285 section_clauses
.nowait
= true;
6287 gfc_start_block (&block
);
6288 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6291 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
6292 if (TREE_CODE (stmt
) != BIND_EXPR
)
6293 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6296 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_PARALLEL
,
6297 void_type_node
, stmt
, omp_clauses
);
6298 OMP_PARALLEL_COMBINED (stmt
) = 1;
6299 gfc_add_expr_to_block (&block
, stmt
);
6300 return gfc_finish_block (&block
);
6304 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
6307 gfc_omp_clauses workshare_clauses
;
6308 tree stmt
, omp_clauses
;
6310 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
6311 workshare_clauses
.nowait
= true;
6313 gfc_start_block (&block
);
6314 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6317 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
6318 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6319 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_PARALLEL
,
6320 void_type_node
, stmt
, omp_clauses
);
6321 OMP_PARALLEL_COMBINED (stmt
) = 1;
6322 gfc_add_expr_to_block (&block
, stmt
);
6323 return gfc_finish_block (&block
);
6327 gfc_trans_omp_scope (gfc_code
*code
)
6330 tree body
= gfc_trans_code (code
->block
->next
);
6331 if (IS_EMPTY_STMT (body
))
6333 gfc_start_block (&block
);
6334 tree omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6336 tree stmt
= make_node (OMP_SCOPE
);
6337 TREE_TYPE (stmt
) = void_type_node
;
6338 OMP_SCOPE_BODY (stmt
) = body
;
6339 OMP_SCOPE_CLAUSES (stmt
) = omp_clauses
;
6340 gfc_add_expr_to_block (&block
, stmt
);
6341 return gfc_finish_block (&block
);
6345 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
6347 stmtblock_t block
, body
;
6348 tree omp_clauses
, stmt
;
6349 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
6350 location_t loc
= gfc_get_location (&code
->loc
);
6352 gfc_start_block (&block
);
6354 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
6356 gfc_init_block (&body
);
6357 for (code
= code
->block
; code
; code
= code
->block
)
6359 /* Last section is special because of lastprivate, so even if it
6360 is empty, chain it in. */
6361 stmt
= gfc_trans_omp_code (code
->next
,
6362 has_lastprivate
&& code
->block
== NULL
);
6363 if (! IS_EMPTY_STMT (stmt
))
6365 stmt
= build1_v (OMP_SECTION
, stmt
);
6366 gfc_add_expr_to_block (&body
, stmt
);
6369 stmt
= gfc_finish_block (&body
);
6371 stmt
= build2_loc (loc
, OMP_SECTIONS
, void_type_node
, stmt
, omp_clauses
);
6372 gfc_add_expr_to_block (&block
, stmt
);
6374 return gfc_finish_block (&block
);
6378 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
6380 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
6381 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6382 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_SINGLE
, void_type_node
,
6388 gfc_trans_omp_task (gfc_code
*code
)
6391 tree stmt
, omp_clauses
;
6393 gfc_start_block (&block
);
6394 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6397 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6398 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6399 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_TASK
, void_type_node
,
6401 gfc_add_expr_to_block (&block
, stmt
);
6402 return gfc_finish_block (&block
);
6406 gfc_trans_omp_taskgroup (gfc_code
*code
)
6408 tree body
= gfc_trans_code (code
->block
->next
);
6409 tree stmt
= make_node (OMP_TASKGROUP
);
6410 TREE_TYPE (stmt
) = void_type_node
;
6411 OMP_TASKGROUP_BODY (stmt
) = body
;
6412 OMP_TASKGROUP_CLAUSES (stmt
) = NULL_TREE
;
6417 gfc_trans_omp_taskwait (gfc_code
*code
)
6419 if (!code
->ext
.omp_clauses
)
6421 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT
);
6422 return build_call_expr_loc (input_location
, decl
, 0);
6425 gfc_start_block (&block
);
6426 tree stmt
= make_node (OMP_TASK
);
6427 TREE_TYPE (stmt
) = void_type_node
;
6428 OMP_TASK_BODY (stmt
) = NULL_TREE
;
6429 OMP_TASK_CLAUSES (stmt
) = gfc_trans_omp_clauses (&block
,
6430 code
->ext
.omp_clauses
,
6432 gfc_add_expr_to_block (&block
, stmt
);
6433 return gfc_finish_block (&block
);
6437 gfc_trans_omp_taskyield (void)
6439 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD
);
6440 return build_call_expr_loc (input_location
, decl
, 0);
6444 gfc_trans_omp_distribute (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
6447 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
6448 tree stmt
, omp_clauses
= NULL_TREE
;
6449 bool free_clausesa
= false;
6451 gfc_start_block (&block
);
6452 if (clausesa
== NULL
)
6454 clausesa
= clausesa_buf
;
6455 gfc_split_omp_clauses (code
, clausesa
);
6456 free_clausesa
= true;
6460 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
6464 case EXEC_OMP_DISTRIBUTE
:
6465 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6466 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6467 /* This is handled in gfc_trans_omp_do. */
6470 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
6471 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6472 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6473 stmt
= gfc_trans_omp_parallel_do (code
, false, &block
, clausesa
);
6474 if (TREE_CODE (stmt
) != BIND_EXPR
)
6475 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6479 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6480 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6481 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6482 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
6483 if (TREE_CODE (stmt
) != BIND_EXPR
)
6484 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6488 case EXEC_OMP_DISTRIBUTE_SIMD
:
6489 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6490 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
6491 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
6492 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
6493 if (TREE_CODE (stmt
) != BIND_EXPR
)
6494 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6503 tree distribute
= make_node (OMP_DISTRIBUTE
);
6504 TREE_TYPE (distribute
) = void_type_node
;
6505 OMP_FOR_BODY (distribute
) = stmt
;
6506 OMP_FOR_CLAUSES (distribute
) = omp_clauses
;
6509 gfc_add_expr_to_block (&block
, stmt
);
6511 gfc_free_split_omp_clauses (code
, clausesa
);
6512 return gfc_finish_block (&block
);
6516 gfc_trans_omp_teams (gfc_code
*code
, gfc_omp_clauses
*clausesa
,
6520 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
6522 bool combined
= true, free_clausesa
= false;
6524 gfc_start_block (&block
);
6525 if (clausesa
== NULL
)
6527 clausesa
= clausesa_buf
;
6528 gfc_split_omp_clauses (code
, clausesa
);
6529 free_clausesa
= true;
6534 = chainon (omp_clauses
,
6535 gfc_trans_omp_clauses (&block
,
6536 &clausesa
[GFC_OMP_SPLIT_TEAMS
],
6542 case EXEC_OMP_TARGET_TEAMS
:
6543 case EXEC_OMP_TEAMS
:
6544 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6547 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6548 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6549 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DISTRIBUTE
, NULL
,
6550 &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
6553 case EXEC_OMP_TARGET_TEAMS_LOOP
:
6554 case EXEC_OMP_TEAMS_LOOP
:
6555 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_LOOP
, NULL
,
6556 &clausesa
[GFC_OMP_SPLIT_DO
],
6560 stmt
= gfc_trans_omp_distribute (code
, clausesa
);
6565 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6566 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_TEAMS
,
6567 void_type_node
, stmt
, omp_clauses
);
6569 OMP_TEAMS_COMBINED (stmt
) = 1;
6571 gfc_add_expr_to_block (&block
, stmt
);
6573 gfc_free_split_omp_clauses (code
, clausesa
);
6574 return gfc_finish_block (&block
);
6578 gfc_trans_omp_target (gfc_code
*code
)
6581 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
6582 tree stmt
, omp_clauses
= NULL_TREE
;
6584 gfc_start_block (&block
);
6585 gfc_split_omp_clauses (code
, clausesa
);
6588 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TARGET
],
6592 case EXEC_OMP_TARGET
:
6594 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6595 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6597 case EXEC_OMP_TARGET_PARALLEL
:
6602 gfc_start_block (&iblock
);
6604 = gfc_trans_omp_clauses (&iblock
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
6606 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6607 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
6609 gfc_add_expr_to_block (&iblock
, stmt
);
6610 stmt
= gfc_finish_block (&iblock
);
6611 if (TREE_CODE (stmt
) != BIND_EXPR
)
6612 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6617 case EXEC_OMP_TARGET_PARALLEL_DO
:
6618 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
6619 stmt
= gfc_trans_omp_parallel_do (code
,
6621 == EXEC_OMP_TARGET_PARALLEL_LOOP
),
6623 if (TREE_CODE (stmt
) != BIND_EXPR
)
6624 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6628 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
6629 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
6630 if (TREE_CODE (stmt
) != BIND_EXPR
)
6631 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6635 case EXEC_OMP_TARGET_SIMD
:
6636 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
6637 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
6638 if (TREE_CODE (stmt
) != BIND_EXPR
)
6639 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6645 && (clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
6646 || clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
))
6648 gfc_omp_clauses clausesb
;
6650 /* For combined !$omp target teams, the num_teams and
6651 thread_limit clauses are evaluated before entering the
6652 target construct. */
6653 memset (&clausesb
, '\0', sizeof (clausesb
));
6654 clausesb
.num_teams
= clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
;
6655 clausesb
.thread_limit
= clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
;
6656 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
= NULL
;
6657 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
= NULL
;
6659 = gfc_trans_omp_clauses (&block
, &clausesb
, code
->loc
);
6661 stmt
= gfc_trans_omp_teams (code
, clausesa
, teams_clauses
);
6666 stmt
= gfc_trans_omp_teams (code
, clausesa
, NULL_TREE
);
6668 if (TREE_CODE (stmt
) != BIND_EXPR
)
6669 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6676 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_TARGET
,
6677 void_type_node
, stmt
, omp_clauses
);
6678 if (code
->op
!= EXEC_OMP_TARGET
)
6679 OMP_TARGET_COMBINED (stmt
) = 1;
6680 cfun
->has_omp_target
= true;
6682 gfc_add_expr_to_block (&block
, stmt
);
6683 gfc_free_split_omp_clauses (code
, clausesa
);
6684 return gfc_finish_block (&block
);
6688 gfc_trans_omp_taskloop (gfc_code
*code
, gfc_exec_op op
)
6691 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
6692 tree stmt
, omp_clauses
= NULL_TREE
;
6694 gfc_start_block (&block
);
6695 gfc_split_omp_clauses (code
, clausesa
);
6698 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TASKLOOP
],
6702 case EXEC_OMP_TASKLOOP
:
6703 /* This is handled in gfc_trans_omp_do. */
6706 case EXEC_OMP_TASKLOOP_SIMD
:
6707 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
6708 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
6709 if (TREE_CODE (stmt
) != BIND_EXPR
)
6710 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6719 tree taskloop
= make_node (OMP_TASKLOOP
);
6720 TREE_TYPE (taskloop
) = void_type_node
;
6721 OMP_FOR_BODY (taskloop
) = stmt
;
6722 OMP_FOR_CLAUSES (taskloop
) = omp_clauses
;
6725 gfc_add_expr_to_block (&block
, stmt
);
6726 gfc_free_split_omp_clauses (code
, clausesa
);
6727 return gfc_finish_block (&block
);
6731 gfc_trans_omp_master_masked_taskloop (gfc_code
*code
, gfc_exec_op op
)
6733 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
6737 if (op
!= EXEC_OMP_MASTER_TASKLOOP_SIMD
6738 && code
->op
!= EXEC_OMP_MASTER_TASKLOOP
)
6739 gfc_split_omp_clauses (code
, clausesa
);
6742 if (op
== EXEC_OMP_MASKED_TASKLOOP_SIMD
6743 || op
== EXEC_OMP_MASTER_TASKLOOP_SIMD
)
6744 stmt
= gfc_trans_omp_taskloop (code
, EXEC_OMP_TASKLOOP_SIMD
);
6747 gcc_assert (op
== EXEC_OMP_MASKED_TASKLOOP
6748 || op
== EXEC_OMP_MASTER_TASKLOOP
);
6749 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_TASKLOOP
, NULL
,
6750 code
->op
!= EXEC_OMP_MASTER_TASKLOOP
6751 ? &clausesa
[GFC_OMP_SPLIT_TASKLOOP
]
6752 : code
->ext
.omp_clauses
, NULL
);
6754 if (TREE_CODE (stmt
) != BIND_EXPR
)
6755 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6758 gfc_start_block (&block
);
6759 if (op
== EXEC_OMP_MASKED_TASKLOOP
|| op
== EXEC_OMP_MASKED_TASKLOOP_SIMD
)
6761 tree clauses
= gfc_trans_omp_clauses (&block
,
6762 &clausesa
[GFC_OMP_SPLIT_MASKED
],
6764 tree msk
= make_node (OMP_MASKED
);
6765 TREE_TYPE (msk
) = void_type_node
;
6766 OMP_MASKED_BODY (msk
) = stmt
;
6767 OMP_MASKED_CLAUSES (msk
) = clauses
;
6768 OMP_MASKED_COMBINED (msk
) = 1;
6769 gfc_add_expr_to_block (&block
, msk
);
6773 gcc_assert (op
== EXEC_OMP_MASTER_TASKLOOP
6774 || op
== EXEC_OMP_MASTER_TASKLOOP_SIMD
);
6775 stmt
= build1_v (OMP_MASTER
, stmt
);
6776 gfc_add_expr_to_block (&block
, stmt
);
6778 if (op
!= EXEC_OMP_MASTER_TASKLOOP_SIMD
6779 && code
->op
!= EXEC_OMP_MASTER_TASKLOOP
)
6780 gfc_free_split_omp_clauses (code
, clausesa
);
6781 return gfc_finish_block (&block
);
6785 gfc_trans_omp_parallel_master_masked (gfc_code
*code
)
6788 tree stmt
, omp_clauses
;
6789 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
6790 bool parallel_combined
= false;
6792 if (code
->op
!= EXEC_OMP_PARALLEL_MASTER
)
6793 gfc_split_omp_clauses (code
, clausesa
);
6795 gfc_start_block (&block
);
6796 omp_clauses
= gfc_trans_omp_clauses (&block
,
6797 code
->op
== EXEC_OMP_PARALLEL_MASTER
6798 ? code
->ext
.omp_clauses
6799 : &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
6802 if (code
->op
== EXEC_OMP_PARALLEL_MASTER
)
6803 stmt
= gfc_trans_omp_master (code
);
6804 else if (code
->op
== EXEC_OMP_PARALLEL_MASKED
)
6805 stmt
= gfc_trans_omp_masked (code
, &clausesa
[GFC_OMP_SPLIT_MASKED
]);
6811 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
6812 op
= EXEC_OMP_MASKED_TASKLOOP
;
6814 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
6815 op
= EXEC_OMP_MASKED_TASKLOOP_SIMD
;
6817 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
6818 op
= EXEC_OMP_MASTER_TASKLOOP
;
6820 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
6821 op
= EXEC_OMP_MASTER_TASKLOOP_SIMD
;
6826 stmt
= gfc_trans_omp_master_masked_taskloop (code
, op
);
6827 parallel_combined
= true;
6829 if (TREE_CODE (stmt
) != BIND_EXPR
)
6830 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
6833 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_PARALLEL
,
6834 void_type_node
, stmt
, omp_clauses
);
6835 /* masked does have just filter clause, but during gimplification
6836 isn't represented by a gimplification omp context, so for
6837 !$omp parallel masked don't set OMP_PARALLEL_COMBINED,
6839 !$omp parallel masked
6840 !$omp taskloop simd lastprivate (x)
6842 !$omp parallel masked taskloop simd lastprivate (x) */
6843 if (parallel_combined
)
6844 OMP_PARALLEL_COMBINED (stmt
) = 1;
6845 gfc_add_expr_to_block (&block
, stmt
);
6846 if (code
->op
!= EXEC_OMP_PARALLEL_MASTER
)
6847 gfc_free_split_omp_clauses (code
, clausesa
);
6848 return gfc_finish_block (&block
);
6852 gfc_trans_omp_target_data (gfc_code
*code
)
6855 tree stmt
, omp_clauses
;
6857 gfc_start_block (&block
);
6858 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6860 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
6861 stmt
= build2_loc (gfc_get_location (&code
->loc
), OMP_TARGET_DATA
,
6862 void_type_node
, stmt
, omp_clauses
);
6863 gfc_add_expr_to_block (&block
, stmt
);
6864 return gfc_finish_block (&block
);
6868 gfc_trans_omp_target_enter_data (gfc_code
*code
)
6871 tree stmt
, omp_clauses
;
6873 gfc_start_block (&block
);
6874 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6876 stmt
= build1_loc (input_location
, OMP_TARGET_ENTER_DATA
, void_type_node
,
6878 gfc_add_expr_to_block (&block
, stmt
);
6879 return gfc_finish_block (&block
);
6883 gfc_trans_omp_target_exit_data (gfc_code
*code
)
6886 tree stmt
, omp_clauses
;
6888 gfc_start_block (&block
);
6889 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6891 stmt
= build1_loc (input_location
, OMP_TARGET_EXIT_DATA
, void_type_node
,
6893 gfc_add_expr_to_block (&block
, stmt
);
6894 return gfc_finish_block (&block
);
6898 gfc_trans_omp_target_update (gfc_code
*code
)
6901 tree stmt
, omp_clauses
;
6903 gfc_start_block (&block
);
6904 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
6906 stmt
= build1_loc (input_location
, OMP_TARGET_UPDATE
, void_type_node
,
6908 gfc_add_expr_to_block (&block
, stmt
);
6909 return gfc_finish_block (&block
);
6913 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
6915 tree res
, tmp
, stmt
;
6916 stmtblock_t block
, *pblock
= NULL
;
6917 stmtblock_t singleblock
;
6918 int saved_ompws_flags
;
6919 bool singleblock_in_progress
= false;
6920 /* True if previous gfc_code in workshare construct is not workshared. */
6921 bool prev_singleunit
;
6922 location_t loc
= gfc_get_location (&code
->loc
);
6924 code
= code
->block
->next
;
6928 gfc_start_block (&block
);
6931 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
6932 prev_singleunit
= false;
6934 /* Translate statements one by one to trees until we reach
6935 the end of the workshare construct. Adjacent gfc_codes that
6936 are a single unit of work are clustered and encapsulated in a
6937 single OMP_SINGLE construct. */
6938 for (; code
; code
= code
->next
)
6940 if (code
->here
!= 0)
6942 res
= gfc_trans_label_here (code
);
6943 gfc_add_expr_to_block (pblock
, res
);
6946 /* No dependence analysis, use for clauses with wait.
6947 If this is the last gfc_code, use default omp_clauses. */
6948 if (code
->next
== NULL
&& clauses
->nowait
)
6949 ompws_flags
|= OMPWS_NOWAIT
;
6951 /* By default, every gfc_code is a single unit of work. */
6952 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
6953 ompws_flags
&= ~(OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
);
6962 res
= gfc_trans_assign (code
);
6965 case EXEC_POINTER_ASSIGN
:
6966 res
= gfc_trans_pointer_assign (code
);
6969 case EXEC_INIT_ASSIGN
:
6970 res
= gfc_trans_init_assign (code
);
6974 res
= gfc_trans_forall (code
);
6978 res
= gfc_trans_where (code
);
6981 case EXEC_OMP_ATOMIC
:
6982 res
= gfc_trans_omp_directive (code
);
6985 case EXEC_OMP_PARALLEL
:
6986 case EXEC_OMP_PARALLEL_DO
:
6987 case EXEC_OMP_PARALLEL_MASTER
:
6988 case EXEC_OMP_PARALLEL_SECTIONS
:
6989 case EXEC_OMP_PARALLEL_WORKSHARE
:
6990 case EXEC_OMP_CRITICAL
:
6991 saved_ompws_flags
= ompws_flags
;
6993 res
= gfc_trans_omp_directive (code
);
6994 ompws_flags
= saved_ompws_flags
;
6998 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
7001 gfc_set_backend_locus (&code
->loc
);
7003 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
7005 if (prev_singleunit
)
7007 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
7008 /* Add current gfc_code to single block. */
7009 gfc_add_expr_to_block (&singleblock
, res
);
7012 /* Finish single block and add it to pblock. */
7013 tmp
= gfc_finish_block (&singleblock
);
7014 tmp
= build2_loc (loc
, OMP_SINGLE
,
7015 void_type_node
, tmp
, NULL_TREE
);
7016 gfc_add_expr_to_block (pblock
, tmp
);
7017 /* Add current gfc_code to pblock. */
7018 gfc_add_expr_to_block (pblock
, res
);
7019 singleblock_in_progress
= false;
7024 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
7026 /* Start single block. */
7027 gfc_init_block (&singleblock
);
7028 gfc_add_expr_to_block (&singleblock
, res
);
7029 singleblock_in_progress
= true;
7030 loc
= gfc_get_location (&code
->loc
);
7033 /* Add the new statement to the block. */
7034 gfc_add_expr_to_block (pblock
, res
);
7036 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
7040 /* Finish remaining SINGLE block, if we were in the middle of one. */
7041 if (singleblock_in_progress
)
7043 /* Finish single block and add it to pblock. */
7044 tmp
= gfc_finish_block (&singleblock
);
7045 tmp
= build2_loc (loc
, OMP_SINGLE
, void_type_node
, tmp
,
7047 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
7049 gfc_add_expr_to_block (pblock
, tmp
);
7052 stmt
= gfc_finish_block (pblock
);
7053 if (TREE_CODE (stmt
) != BIND_EXPR
)
7055 if (!IS_EMPTY_STMT (stmt
))
7057 tree bindblock
= poplevel (1, 0);
7058 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
7066 if (IS_EMPTY_STMT (stmt
) && !clauses
->nowait
)
7067 stmt
= gfc_trans_omp_barrier ();
7074 gfc_trans_oacc_declare (gfc_code
*code
)
7077 tree stmt
, oacc_clauses
;
7078 enum tree_code construct_code
;
7080 construct_code
= OACC_DATA
;
7082 gfc_start_block (&block
);
7084 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.oacc_declare
->clauses
,
7085 code
->loc
, false, true);
7086 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
7087 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
7089 gfc_add_expr_to_block (&block
, stmt
);
7091 return gfc_finish_block (&block
);
7095 gfc_trans_oacc_directive (gfc_code
*code
)
7099 case EXEC_OACC_PARALLEL_LOOP
:
7100 case EXEC_OACC_KERNELS_LOOP
:
7101 case EXEC_OACC_SERIAL_LOOP
:
7102 return gfc_trans_oacc_combined_directive (code
);
7103 case EXEC_OACC_PARALLEL
:
7104 case EXEC_OACC_KERNELS
:
7105 case EXEC_OACC_SERIAL
:
7106 case EXEC_OACC_DATA
:
7107 case EXEC_OACC_HOST_DATA
:
7108 return gfc_trans_oacc_construct (code
);
7109 case EXEC_OACC_LOOP
:
7110 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
7112 case EXEC_OACC_UPDATE
:
7113 case EXEC_OACC_CACHE
:
7114 case EXEC_OACC_ENTER_DATA
:
7115 case EXEC_OACC_EXIT_DATA
:
7116 return gfc_trans_oacc_executable_directive (code
);
7117 case EXEC_OACC_WAIT
:
7118 return gfc_trans_oacc_wait_directive (code
);
7119 case EXEC_OACC_ATOMIC
:
7120 return gfc_trans_omp_atomic (code
);
7121 case EXEC_OACC_DECLARE
:
7122 return gfc_trans_oacc_declare (code
);
7129 gfc_trans_omp_directive (gfc_code
*code
)
7133 case EXEC_OMP_ATOMIC
:
7134 return gfc_trans_omp_atomic (code
);
7135 case EXEC_OMP_BARRIER
:
7136 return gfc_trans_omp_barrier ();
7137 case EXEC_OMP_CANCEL
:
7138 return gfc_trans_omp_cancel (code
);
7139 case EXEC_OMP_CANCELLATION_POINT
:
7140 return gfc_trans_omp_cancellation_point (code
);
7141 case EXEC_OMP_CRITICAL
:
7142 return gfc_trans_omp_critical (code
);
7143 case EXEC_OMP_DEPOBJ
:
7144 return gfc_trans_omp_depobj (code
);
7145 case EXEC_OMP_DISTRIBUTE
:
7149 case EXEC_OMP_TASKLOOP
:
7150 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
7152 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
7153 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
7154 case EXEC_OMP_DISTRIBUTE_SIMD
:
7155 return gfc_trans_omp_distribute (code
, NULL
);
7156 case EXEC_OMP_DO_SIMD
:
7157 return gfc_trans_omp_do_simd (code
, NULL
, NULL
, NULL_TREE
);
7158 case EXEC_OMP_ERROR
:
7159 return gfc_trans_omp_error (code
);
7160 case EXEC_OMP_FLUSH
:
7161 return gfc_trans_omp_flush (code
);
7162 case EXEC_OMP_MASKED
:
7163 return gfc_trans_omp_masked (code
, NULL
);
7164 case EXEC_OMP_MASTER
:
7165 return gfc_trans_omp_master (code
);
7166 case EXEC_OMP_MASKED_TASKLOOP
:
7167 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
7168 case EXEC_OMP_MASTER_TASKLOOP
:
7169 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
7170 return gfc_trans_omp_master_masked_taskloop (code
, code
->op
);
7171 case EXEC_OMP_ORDERED
:
7172 return gfc_trans_omp_ordered (code
);
7173 case EXEC_OMP_PARALLEL
:
7174 return gfc_trans_omp_parallel (code
);
7175 case EXEC_OMP_PARALLEL_DO
:
7176 return gfc_trans_omp_parallel_do (code
, false, NULL
, NULL
);
7177 case EXEC_OMP_PARALLEL_LOOP
:
7178 return gfc_trans_omp_parallel_do (code
, true, NULL
, NULL
);
7179 case EXEC_OMP_PARALLEL_DO_SIMD
:
7180 return gfc_trans_omp_parallel_do_simd (code
, NULL
, NULL
);
7181 case EXEC_OMP_PARALLEL_MASKED
:
7182 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
7183 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
7184 case EXEC_OMP_PARALLEL_MASTER
:
7185 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
7186 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
7187 return gfc_trans_omp_parallel_master_masked (code
);
7188 case EXEC_OMP_PARALLEL_SECTIONS
:
7189 return gfc_trans_omp_parallel_sections (code
);
7190 case EXEC_OMP_PARALLEL_WORKSHARE
:
7191 return gfc_trans_omp_parallel_workshare (code
);
7192 case EXEC_OMP_SCOPE
:
7193 return gfc_trans_omp_scope (code
);
7194 case EXEC_OMP_SECTIONS
:
7195 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
7196 case EXEC_OMP_SINGLE
:
7197 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
7198 case EXEC_OMP_TARGET
:
7199 case EXEC_OMP_TARGET_PARALLEL
:
7200 case EXEC_OMP_TARGET_PARALLEL_DO
:
7201 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
7202 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
7203 case EXEC_OMP_TARGET_SIMD
:
7204 case EXEC_OMP_TARGET_TEAMS
:
7205 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
7206 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
7207 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
7208 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
7209 case EXEC_OMP_TARGET_TEAMS_LOOP
:
7210 return gfc_trans_omp_target (code
);
7211 case EXEC_OMP_TARGET_DATA
:
7212 return gfc_trans_omp_target_data (code
);
7213 case EXEC_OMP_TARGET_ENTER_DATA
:
7214 return gfc_trans_omp_target_enter_data (code
);
7215 case EXEC_OMP_TARGET_EXIT_DATA
:
7216 return gfc_trans_omp_target_exit_data (code
);
7217 case EXEC_OMP_TARGET_UPDATE
:
7218 return gfc_trans_omp_target_update (code
);
7220 return gfc_trans_omp_task (code
);
7221 case EXEC_OMP_TASKGROUP
:
7222 return gfc_trans_omp_taskgroup (code
);
7223 case EXEC_OMP_TASKLOOP_SIMD
:
7224 return gfc_trans_omp_taskloop (code
, code
->op
);
7225 case EXEC_OMP_TASKWAIT
:
7226 return gfc_trans_omp_taskwait (code
);
7227 case EXEC_OMP_TASKYIELD
:
7228 return gfc_trans_omp_taskyield ();
7229 case EXEC_OMP_TEAMS
:
7230 case EXEC_OMP_TEAMS_DISTRIBUTE
:
7231 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
7232 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
7233 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
7234 case EXEC_OMP_TEAMS_LOOP
:
7235 return gfc_trans_omp_teams (code
, NULL
, NULL_TREE
);
7236 case EXEC_OMP_WORKSHARE
:
7237 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);
7244 gfc_trans_omp_declare_simd (gfc_namespace
*ns
)
7249 gfc_omp_declare_simd
*ods
;
7250 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
7252 tree c
= gfc_trans_omp_clauses (NULL
, ods
->clauses
, ods
->where
, true);
7253 tree fndecl
= ns
->proc_name
->backend_decl
;
7255 c
= tree_cons (NULL_TREE
, c
, NULL_TREE
);
7256 c
= build_tree_list (get_identifier ("omp declare simd"), c
);
7257 TREE_CHAIN (c
) = DECL_ATTRIBUTES (fndecl
);
7258 DECL_ATTRIBUTES (fndecl
) = c
;
7263 gfc_trans_omp_declare_variant (gfc_namespace
*ns
)
7265 tree base_fn_decl
= ns
->proc_name
->backend_decl
;
7266 gfc_namespace
*search_ns
= ns
;
7267 gfc_omp_declare_variant
*next
;
7269 for (gfc_omp_declare_variant
*odv
= search_ns
->omp_declare_variant
;
7270 search_ns
; odv
= next
)
7272 /* Look in the parent namespace if there are no more directives in the
7273 current namespace. */
7276 search_ns
= search_ns
->parent
;
7278 next
= search_ns
->omp_declare_variant
;
7287 /* Check directive the first time it is encountered. */
7288 bool error_found
= true;
7291 error_found
= false;
7292 if (odv
->base_proc_symtree
== NULL
)
7294 if (!search_ns
->proc_name
->attr
.function
7295 && !search_ns
->proc_name
->attr
.subroutine
)
7296 gfc_error ("The base name for 'declare variant' must be "
7297 "specified at %L ", &odv
->where
);
7299 error_found
= false;
7303 if (!search_ns
->contained
7304 && strcmp (odv
->base_proc_symtree
->name
,
7305 ns
->proc_name
->name
))
7306 gfc_error ("The base name at %L does not match the name of the "
7307 "current procedure", &odv
->where
);
7308 else if (odv
->base_proc_symtree
->n
.sym
->attr
.entry
)
7309 gfc_error ("The base name at %L must not be an entry name",
7311 else if (odv
->base_proc_symtree
->n
.sym
->attr
.generic
)
7312 gfc_error ("The base name at %L must not be a generic name",
7314 else if (odv
->base_proc_symtree
->n
.sym
->attr
.proc_pointer
)
7315 gfc_error ("The base name at %L must not be a procedure pointer",
7317 else if (odv
->base_proc_symtree
->n
.sym
->attr
.implicit_type
)
7318 gfc_error ("The base procedure at %L must have an explicit "
7319 "interface", &odv
->where
);
7321 error_found
= false;
7324 odv
->checked_p
= true;
7327 odv
->error_p
= true;
7331 /* Ignore directives that do not apply to the current procedure. */
7332 if ((odv
->base_proc_symtree
== NULL
&& search_ns
!= ns
)
7333 || (odv
->base_proc_symtree
!= NULL
7334 && strcmp (odv
->base_proc_symtree
->name
, ns
->proc_name
->name
)))
7337 tree set_selectors
= NULL_TREE
;
7338 gfc_omp_set_selector
*oss
;
7340 for (oss
= odv
->set_selectors
; oss
; oss
= oss
->next
)
7342 tree selectors
= NULL_TREE
;
7343 gfc_omp_selector
*os
;
7344 for (os
= oss
->trait_selectors
; os
; os
= os
->next
)
7346 tree properties
= NULL_TREE
;
7347 gfc_omp_trait_property
*otp
;
7349 for (otp
= os
->properties
; otp
; otp
= otp
->next
)
7351 switch (otp
->property_kind
)
7353 case CTX_PROPERTY_USER
:
7354 case CTX_PROPERTY_EXPR
:
7357 gfc_init_se (&se
, NULL
);
7358 gfc_conv_expr (&se
, otp
->expr
);
7359 properties
= tree_cons (NULL_TREE
, se
.expr
,
7363 case CTX_PROPERTY_ID
:
7364 properties
= tree_cons (get_identifier (otp
->name
),
7365 NULL_TREE
, properties
);
7367 case CTX_PROPERTY_NAME_LIST
:
7369 tree prop
= NULL_TREE
, value
= NULL_TREE
;
7371 prop
= get_identifier (otp
->name
);
7373 value
= gfc_conv_constant_to_tree (otp
->expr
);
7375 properties
= tree_cons (prop
, value
, properties
);
7378 case CTX_PROPERTY_SIMD
:
7379 properties
= gfc_trans_omp_clauses (NULL
, otp
->clauses
,
7390 gfc_init_se (&se
, NULL
);
7391 gfc_conv_expr (&se
, os
->score
);
7392 properties
= tree_cons (get_identifier (" score"),
7393 se
.expr
, properties
);
7396 selectors
= tree_cons (get_identifier (os
->trait_selector_name
),
7397 properties
, selectors
);
7401 = tree_cons (get_identifier (oss
->trait_set_selector_name
),
7402 selectors
, set_selectors
);
7405 const char *variant_proc_name
= odv
->variant_proc_symtree
->name
;
7406 gfc_symbol
*variant_proc_sym
= odv
->variant_proc_symtree
->n
.sym
;
7407 if (variant_proc_sym
== NULL
|| variant_proc_sym
->attr
.implicit_type
)
7409 gfc_symtree
*proc_st
;
7410 gfc_find_sym_tree (variant_proc_name
, gfc_current_ns
, 1, &proc_st
);
7411 variant_proc_sym
= proc_st
->n
.sym
;
7413 if (variant_proc_sym
== NULL
)
7415 gfc_error ("Cannot find symbol %qs", variant_proc_name
);
7418 set_selectors
= omp_check_context_selector
7419 (gfc_get_location (&odv
->where
), set_selectors
);
7420 if (set_selectors
!= error_mark_node
)
7422 if (!variant_proc_sym
->attr
.implicit_type
7423 && !variant_proc_sym
->attr
.subroutine
7424 && !variant_proc_sym
->attr
.function
)
7426 gfc_error ("variant %qs at %L is not a function or subroutine",
7427 variant_proc_name
, &odv
->where
);
7428 variant_proc_sym
= NULL
;
7430 else if (omp_get_context_selector (set_selectors
, "construct",
7431 "simd") == NULL_TREE
)
7434 if (!gfc_compare_interfaces (ns
->proc_name
, variant_proc_sym
,
7435 variant_proc_sym
->name
, 0, 1,
7436 err
, sizeof (err
), NULL
, NULL
))
7438 gfc_error ("variant %qs and base %qs at %L have "
7439 "incompatible types: %s",
7440 variant_proc_name
, ns
->proc_name
->name
,
7442 variant_proc_sym
= NULL
;
7445 if (variant_proc_sym
!= NULL
)
7447 gfc_set_sym_referenced (variant_proc_sym
);
7448 tree construct
= omp_get_context_selector (set_selectors
,
7450 omp_mark_declare_variant (gfc_get_location (&odv
->where
),
7451 gfc_get_symbol_decl (variant_proc_sym
),
7453 if (omp_context_selector_matches (set_selectors
))
7455 tree id
= get_identifier ("omp declare variant base");
7456 tree variant
= gfc_get_symbol_decl (variant_proc_sym
);
7457 DECL_ATTRIBUTES (base_fn_decl
)
7458 = tree_cons (id
, build_tree_list (variant
, set_selectors
),
7459 DECL_ATTRIBUTES (base_fn_decl
));