1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2020 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 "gomp-constants.h"
39 #include "omp-general.h"
42 #define GCC_DIAG_STYLE __gcc_tdiag__
43 #include "diagnostic-core.h"
45 #define GCC_DIAG_STYLE __gcc_gfc__
51 /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
52 allocatable or pointer attribute. */
55 gfc_omp_is_allocatable_or_ptr (const_tree decl
)
58 && (GFC_DECL_GET_SCALAR_POINTER (decl
)
59 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)));
62 /* True if the argument is an optional argument; except that false is also
63 returned for arguments with the value attribute (nonpointers) and for
64 assumed-shape variables (decl is a local variable containing arg->data).
65 Note that pvoid_type_node is for 'type(c_ptr), value. */
68 gfc_omp_is_optional_argument (const_tree decl
)
70 return (TREE_CODE (decl
) == PARM_DECL
71 && DECL_LANG_SPECIFIC (decl
)
72 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
73 && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
74 && GFC_DECL_OPTIONAL_ARGUMENT (decl
));
77 /* Check whether this DECL belongs to a Fortran optional argument.
78 With 'for_present_check' set to false, decls which are optional parameters
79 themselve are returned as tree - or a NULL_TREE otherwise. Those decls are
80 always pointers. With 'for_present_check' set to true, the decl for checking
81 whether an argument is present is returned; for arguments with value
82 attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is
83 unrelated to optional arguments, NULL_TREE is returned. */
86 gfc_omp_check_optional_argument (tree decl
, bool for_present_check
)
88 if (!for_present_check
)
89 return gfc_omp_is_optional_argument (decl
) ? decl
: NULL_TREE
;
91 if (!DECL_LANG_SPECIFIC (decl
))
94 tree orig_decl
= decl
;
96 /* For assumed-shape arrays, a local decl with arg->data is used. */
97 if (TREE_CODE (decl
) != PARM_DECL
98 && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
99 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))))
100 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
102 if (decl
== NULL_TREE
103 || TREE_CODE (decl
) != PARM_DECL
104 || !DECL_LANG_SPECIFIC (decl
)
105 || !GFC_DECL_OPTIONAL_ARGUMENT (decl
))
108 /* Scalars with VALUE attribute which are passed by value use a hidden
109 argument to denote the present status. They are passed as nonpointer type
110 with one exception: 'type(c_ptr), value' as 'void*'. */
111 /* Cf. trans-expr.c's gfc_conv_expr_present. */
112 if (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
113 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
115 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
119 strcpy (&name
[1], IDENTIFIER_POINTER (DECL_NAME (decl
)));
120 tree_name
= get_identifier (name
);
122 /* Walk function argument list to find the hidden arg. */
123 decl
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
124 for ( ; decl
!= NULL_TREE
; decl
= TREE_CHAIN (decl
))
125 if (DECL_NAME (decl
) == tree_name
126 && DECL_ARTIFICIAL (decl
))
133 return fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
134 orig_decl
, null_pointer_node
);
138 /* Returns tree with NULL if it is not an array descriptor and with the tree to
139 access the 'data' component otherwise. With type_only = true, it returns the
140 TREE_TYPE without creating a new tree. */
143 gfc_omp_array_data (tree decl
, bool type_only
)
145 tree type
= TREE_TYPE (decl
);
147 if (POINTER_TYPE_P (type
))
148 type
= TREE_TYPE (type
);
150 if (!GFC_DESCRIPTOR_TYPE_P (type
))
154 return GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
156 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
157 decl
= build_fold_indirect_ref (decl
);
159 decl
= gfc_conv_descriptor_data_get (decl
);
164 /* True if OpenMP should privatize what this DECL points to rather
165 than the DECL itself. */
168 gfc_omp_privatize_by_reference (const_tree decl
)
170 tree type
= TREE_TYPE (decl
);
172 if (TREE_CODE (type
) == REFERENCE_TYPE
173 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
176 if (TREE_CODE (type
) == POINTER_TYPE
177 && gfc_omp_is_optional_argument (decl
))
180 if (TREE_CODE (type
) == POINTER_TYPE
)
182 while (TREE_CODE (decl
) == COMPONENT_REF
)
183 decl
= TREE_OPERAND (decl
, 1);
185 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
186 that have POINTER_TYPE type and aren't scalar pointers, scalar
187 allocatables, Cray pointees or C pointers are supposed to be
188 privatized by reference. */
189 if (GFC_DECL_GET_SCALAR_POINTER (decl
)
190 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
191 || GFC_DECL_CRAY_POINTEE (decl
)
192 || GFC_DECL_ASSOCIATE_VAR_P (decl
)
193 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
196 if (!DECL_ARTIFICIAL (decl
)
197 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
200 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
202 if (DECL_LANG_SPECIFIC (decl
)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
210 /* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
211 of DECL is predetermined. */
213 enum omp_clause_default_kind
214 gfc_omp_predetermined_sharing (tree decl
)
216 /* Associate names preserve the association established during ASSOCIATE.
217 As they are implemented either as pointers to the selector or array
218 descriptor and shouldn't really change in the ASSOCIATE region,
219 this decl can be either shared or firstprivate. If it is a pointer,
220 use firstprivate, as it is cheaper that way, otherwise make it shared. */
221 if (GFC_DECL_ASSOCIATE_VAR_P (decl
))
223 if (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
224 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
226 return OMP_CLAUSE_DEFAULT_SHARED
;
229 if (DECL_ARTIFICIAL (decl
)
230 && ! GFC_DECL_RESULT (decl
)
231 && ! (DECL_LANG_SPECIFIC (decl
)
232 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
233 return OMP_CLAUSE_DEFAULT_SHARED
;
235 /* Cray pointees shouldn't be listed in any clauses and should be
236 gimplified to dereference of the corresponding Cray pointer.
237 Make them all private, so that they are emitted in the debug
239 if (GFC_DECL_CRAY_POINTEE (decl
))
240 return OMP_CLAUSE_DEFAULT_PRIVATE
;
242 /* Assumed-size arrays are predetermined shared. */
243 if (TREE_CODE (decl
) == PARM_DECL
244 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
245 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
246 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
247 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
249 return OMP_CLAUSE_DEFAULT_SHARED
;
251 /* Dummy procedures aren't considered variables by OpenMP, thus are
252 disallowed in OpenMP clauses. They are represented as PARM_DECLs
253 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
254 to avoid complaining about their uses with default(none). */
255 if (TREE_CODE (decl
) == PARM_DECL
256 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
257 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
258 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
260 /* COMMON and EQUIVALENCE decls are shared. They
261 are only referenced through DECL_VALUE_EXPR of the variables
262 contained in them. If those are privatized, they will not be
263 gimplified to the COMMON or EQUIVALENCE decls. */
264 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
265 return OMP_CLAUSE_DEFAULT_SHARED
;
267 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
268 return OMP_CLAUSE_DEFAULT_SHARED
;
270 /* These are either array or derived parameters, or vtables.
271 In the former cases, the OpenMP standard doesn't consider them to be
272 variables at all (they can't be redefined), but they can nevertheless appear
273 in parallel/task regions and for default(none) purposes treat them as shared.
274 For vtables likely the same handling is desirable. */
275 if (VAR_P (decl
) && TREE_READONLY (decl
)
276 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
277 return OMP_CLAUSE_DEFAULT_SHARED
;
279 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
283 /* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
284 of DECL is predetermined. */
286 enum omp_clause_defaultmap_kind
287 gfc_omp_predetermined_mapping (tree decl
)
289 if (DECL_ARTIFICIAL (decl
)
290 && ! GFC_DECL_RESULT (decl
)
291 && ! (DECL_LANG_SPECIFIC (decl
)
292 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
293 return OMP_CLAUSE_DEFAULTMAP_TO
;
295 /* These are either array or derived parameters, or vtables. */
296 if (VAR_P (decl
) && TREE_READONLY (decl
)
297 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
298 return OMP_CLAUSE_DEFAULTMAP_TO
;
300 return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED
;
304 /* Return decl that should be used when reporting DEFAULT(NONE)
308 gfc_omp_report_decl (tree decl
)
310 if (DECL_ARTIFICIAL (decl
)
311 && DECL_LANG_SPECIFIC (decl
)
312 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
313 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
318 /* Return true if TYPE has any allocatable components. */
321 gfc_has_alloc_comps (tree type
, tree decl
)
325 if (POINTER_TYPE_P (type
))
327 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
328 type
= TREE_TYPE (type
);
329 else if (GFC_DECL_GET_SCALAR_POINTER (decl
))
333 if (GFC_DESCRIPTOR_TYPE_P (type
)
334 && (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
335 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
))
338 if (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
))
339 type
= gfc_get_element_type (type
);
341 if (TREE_CODE (type
) != RECORD_TYPE
)
344 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
346 ftype
= TREE_TYPE (field
);
347 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
349 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
350 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
352 if (gfc_has_alloc_comps (ftype
, field
))
358 /* Return true if DECL in private clause needs
359 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
361 gfc_omp_private_outer_ref (tree decl
)
363 tree type
= TREE_TYPE (decl
);
365 if (gfc_omp_privatize_by_reference (decl
))
366 type
= TREE_TYPE (type
);
368 if (GFC_DESCRIPTOR_TYPE_P (type
)
369 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
372 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
375 if (gfc_has_alloc_comps (type
, decl
))
381 /* Callback for gfc_omp_unshare_expr. */
384 gfc_omp_unshare_expr_r (tree
*tp
, int *walk_subtrees
, void *)
387 enum tree_code code
= TREE_CODE (t
);
389 /* Stop at types, decls, constants like copy_tree_r. */
390 if (TREE_CODE_CLASS (code
) == tcc_type
391 || TREE_CODE_CLASS (code
) == tcc_declaration
392 || TREE_CODE_CLASS (code
) == tcc_constant
395 else if (handled_component_p (t
)
396 || TREE_CODE (t
) == MEM_REF
)
398 *tp
= unshare_expr (t
);
405 /* Unshare in expr anything that the FE which normally doesn't
406 care much about tree sharing (because during gimplification
407 everything is unshared) could cause problems with tree sharing
408 at omp-low.c time. */
411 gfc_omp_unshare_expr (tree expr
)
413 walk_tree (&expr
, gfc_omp_unshare_expr_r
, NULL
, NULL
);
417 enum walk_alloc_comps
419 WALK_ALLOC_COMPS_DTOR
,
420 WALK_ALLOC_COMPS_DEFAULT_CTOR
,
421 WALK_ALLOC_COMPS_COPY_CTOR
424 /* Handle allocatable components in OpenMP clauses. */
427 gfc_walk_alloc_comps (tree decl
, tree dest
, tree var
,
428 enum walk_alloc_comps kind
)
430 stmtblock_t block
, tmpblock
;
431 tree type
= TREE_TYPE (decl
), then_b
, tem
, field
;
432 gfc_init_block (&block
);
434 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
436 if (GFC_DESCRIPTOR_TYPE_P (type
))
438 gfc_init_block (&tmpblock
);
439 tem
= gfc_full_array_size (&tmpblock
, decl
,
440 GFC_TYPE_ARRAY_RANK (type
));
441 then_b
= gfc_finish_block (&tmpblock
);
442 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (then_b
));
443 tem
= gfc_omp_unshare_expr (tem
);
444 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
445 gfc_array_index_type
, tem
,
450 bool compute_nelts
= false;
451 if (!TYPE_DOMAIN (type
)
452 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
453 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
454 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
455 compute_nelts
= true;
456 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
458 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
459 if (lookup_attribute ("omp dummy var", a
))
460 compute_nelts
= true;
464 tem
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
465 TYPE_SIZE_UNIT (type
),
466 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
467 tem
= size_binop (MINUS_EXPR
, tem
, size_one_node
);
470 tem
= array_type_nelts (type
);
471 tem
= fold_convert (gfc_array_index_type
, tem
);
474 tree nelems
= gfc_evaluate_now (tem
, &block
);
475 tree index
= gfc_create_var (gfc_array_index_type
, "S");
477 gfc_init_block (&tmpblock
);
478 tem
= gfc_conv_array_data (decl
);
479 tree declvar
= build_fold_indirect_ref_loc (input_location
, tem
);
480 tree declvref
= gfc_build_array_ref (declvar
, index
, NULL
);
481 tree destvar
, destvref
= NULL_TREE
;
484 tem
= gfc_conv_array_data (dest
);
485 destvar
= build_fold_indirect_ref_loc (input_location
, tem
);
486 destvref
= gfc_build_array_ref (destvar
, index
, NULL
);
488 gfc_add_expr_to_block (&tmpblock
,
489 gfc_walk_alloc_comps (declvref
, destvref
,
493 gfc_init_loopinfo (&loop
);
495 loop
.from
[0] = gfc_index_zero_node
;
496 loop
.loopvar
[0] = index
;
498 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
499 gfc_add_block_to_block (&block
, &loop
.pre
);
500 return gfc_finish_block (&block
);
502 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var
))
504 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
506 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
507 type
= TREE_TYPE (decl
);
510 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
511 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
513 tree ftype
= TREE_TYPE (field
);
514 tree declf
, destf
= NULL_TREE
;
515 bool has_alloc_comps
= gfc_has_alloc_comps (ftype
, field
);
516 if ((!GFC_DESCRIPTOR_TYPE_P (ftype
)
517 || GFC_TYPE_ARRAY_AKIND (ftype
) != GFC_ARRAY_ALLOCATABLE
)
518 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field
)
521 declf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
522 decl
, field
, NULL_TREE
);
524 destf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
525 dest
, field
, NULL_TREE
);
530 case WALK_ALLOC_COMPS_DTOR
:
532 case WALK_ALLOC_COMPS_DEFAULT_CTOR
:
533 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
534 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
536 gfc_add_modify (&block
, unshare_expr (destf
),
537 unshare_expr (declf
));
538 tem
= gfc_duplicate_allocatable_nocopy
539 (destf
, declf
, ftype
,
540 GFC_TYPE_ARRAY_RANK (ftype
));
542 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
543 tem
= gfc_duplicate_allocatable_nocopy (destf
, declf
, ftype
, 0);
545 case WALK_ALLOC_COMPS_COPY_CTOR
:
546 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
547 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
548 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
,
549 GFC_TYPE_ARRAY_RANK (ftype
),
551 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
552 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
, 0,
557 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
560 gfc_init_block (&tmpblock
);
561 gfc_add_expr_to_block (&tmpblock
,
562 gfc_walk_alloc_comps (declf
, destf
,
564 then_b
= gfc_finish_block (&tmpblock
);
565 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
566 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
567 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
568 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
569 tem
= unshare_expr (declf
);
574 tem
= fold_convert (pvoid_type_node
, tem
);
575 tem
= fold_build2_loc (input_location
, NE_EXPR
,
576 logical_type_node
, tem
,
578 then_b
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
580 build_empty_stmt (input_location
));
582 gfc_add_expr_to_block (&block
, then_b
);
584 if (kind
== WALK_ALLOC_COMPS_DTOR
)
586 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
587 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
589 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
590 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
,
591 NULL_TREE
, NULL_TREE
, true,
593 GFC_CAF_COARRAY_NOCOARRAY
);
594 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
596 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
598 tem
= gfc_call_free (unshare_expr (declf
));
599 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
604 return gfc_finish_block (&block
);
607 /* Return code to initialize DECL with its default constructor, or
608 NULL if there's nothing to do. */
611 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
613 tree type
= TREE_TYPE (decl
), size
, ptr
, cond
, then_b
, else_b
;
614 stmtblock_t block
, cond_block
;
616 switch (OMP_CLAUSE_CODE (clause
))
618 case OMP_CLAUSE__LOOPTEMP_
:
619 case OMP_CLAUSE__REDUCTEMP_
:
620 case OMP_CLAUSE__CONDTEMP_
:
621 case OMP_CLAUSE__SCANTEMP_
:
623 case OMP_CLAUSE_PRIVATE
:
624 case OMP_CLAUSE_LASTPRIVATE
:
625 case OMP_CLAUSE_LINEAR
:
626 case OMP_CLAUSE_REDUCTION
:
632 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
633 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
634 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
635 || !POINTER_TYPE_P (type
)))
637 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
640 gfc_start_block (&block
);
641 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
642 OMP_CLAUSE_DECL (clause
),
643 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
644 gfc_add_expr_to_block (&block
, tem
);
645 return gfc_finish_block (&block
);
650 gcc_assert (outer
!= NULL_TREE
);
652 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
653 "not currently allocated" allocation status if outer
654 array is "not currently allocated", otherwise should be allocated. */
655 gfc_start_block (&block
);
657 gfc_init_block (&cond_block
);
659 if (GFC_DESCRIPTOR_TYPE_P (type
))
661 gfc_add_modify (&cond_block
, decl
, outer
);
662 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
663 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
664 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
666 gfc_conv_descriptor_lbound_get (decl
, rank
));
667 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
668 size
, gfc_index_one_node
);
669 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
670 size
= fold_build2_loc (input_location
, MULT_EXPR
,
671 gfc_array_index_type
, size
,
672 gfc_conv_descriptor_stride_get (decl
, rank
));
673 tree esize
= fold_convert (gfc_array_index_type
,
674 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
675 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
677 size
= unshare_expr (size
);
678 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
682 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
683 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
684 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
685 if (GFC_DESCRIPTOR_TYPE_P (type
))
686 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
), ptr
);
688 gfc_add_modify (&cond_block
, unshare_expr (decl
),
689 fold_convert (TREE_TYPE (decl
), ptr
));
690 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
692 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
693 OMP_CLAUSE_DECL (clause
),
694 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
695 gfc_add_expr_to_block (&cond_block
, tem
);
697 then_b
= gfc_finish_block (&cond_block
);
699 /* Reduction clause requires allocated ALLOCATABLE. */
700 if (OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_REDUCTION
)
702 gfc_init_block (&cond_block
);
703 if (GFC_DESCRIPTOR_TYPE_P (type
))
704 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
),
707 gfc_add_modify (&cond_block
, unshare_expr (decl
),
708 build_zero_cst (TREE_TYPE (decl
)));
709 else_b
= gfc_finish_block (&cond_block
);
711 tree tem
= fold_convert (pvoid_type_node
,
712 GFC_DESCRIPTOR_TYPE_P (type
)
713 ? gfc_conv_descriptor_data_get (outer
) : outer
);
714 tem
= unshare_expr (tem
);
715 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
716 tem
, null_pointer_node
);
717 gfc_add_expr_to_block (&block
,
718 build3_loc (input_location
, COND_EXPR
,
719 void_type_node
, cond
, then_b
,
721 /* Avoid -W*uninitialized warnings. */
723 TREE_NO_WARNING (decl
) = 1;
726 gfc_add_expr_to_block (&block
, then_b
);
728 return gfc_finish_block (&block
);
731 /* Build and return code for a copy constructor from SRC to DEST. */
734 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
736 tree type
= TREE_TYPE (dest
), ptr
, size
, call
;
737 tree cond
, then_b
, else_b
;
738 stmtblock_t block
, cond_block
;
740 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
741 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
743 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
744 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
745 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
746 || !POINTER_TYPE_P (type
)))
748 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
750 gfc_start_block (&block
);
751 gfc_add_modify (&block
, dest
, src
);
752 tree tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
753 WALK_ALLOC_COMPS_COPY_CTOR
);
754 gfc_add_expr_to_block (&block
, tem
);
755 return gfc_finish_block (&block
);
758 return build2_v (MODIFY_EXPR
, dest
, src
);
761 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
762 and copied from SRC. */
763 gfc_start_block (&block
);
765 gfc_init_block (&cond_block
);
767 gfc_add_modify (&cond_block
, dest
, src
);
768 if (GFC_DESCRIPTOR_TYPE_P (type
))
770 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
771 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
772 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
774 gfc_conv_descriptor_lbound_get (dest
, rank
));
775 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
776 size
, gfc_index_one_node
);
777 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
778 size
= fold_build2_loc (input_location
, MULT_EXPR
,
779 gfc_array_index_type
, size
,
780 gfc_conv_descriptor_stride_get (dest
, rank
));
781 tree esize
= fold_convert (gfc_array_index_type
,
782 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
783 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
785 size
= unshare_expr (size
);
786 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
790 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
791 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
792 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
793 if (GFC_DESCRIPTOR_TYPE_P (type
))
794 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
), ptr
);
796 gfc_add_modify (&cond_block
, unshare_expr (dest
),
797 fold_convert (TREE_TYPE (dest
), ptr
));
799 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
800 ? gfc_conv_descriptor_data_get (src
) : src
;
801 srcptr
= unshare_expr (srcptr
);
802 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
803 call
= build_call_expr_loc (input_location
,
804 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
806 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
807 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
809 tree tem
= gfc_walk_alloc_comps (src
, dest
,
810 OMP_CLAUSE_DECL (clause
),
811 WALK_ALLOC_COMPS_COPY_CTOR
);
812 gfc_add_expr_to_block (&cond_block
, tem
);
814 then_b
= gfc_finish_block (&cond_block
);
816 gfc_init_block (&cond_block
);
817 if (GFC_DESCRIPTOR_TYPE_P (type
))
818 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
),
821 gfc_add_modify (&cond_block
, unshare_expr (dest
),
822 build_zero_cst (TREE_TYPE (dest
)));
823 else_b
= gfc_finish_block (&cond_block
);
825 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
826 unshare_expr (srcptr
), null_pointer_node
);
827 gfc_add_expr_to_block (&block
,
828 build3_loc (input_location
, COND_EXPR
,
829 void_type_node
, cond
, then_b
, else_b
));
830 /* Avoid -W*uninitialized warnings. */
832 TREE_NO_WARNING (dest
) = 1;
834 return gfc_finish_block (&block
);
837 /* Similarly, except use an intrinsic or pointer assignment operator
841 gfc_omp_clause_assign_op (tree clause
, tree dest
, tree src
)
843 tree type
= TREE_TYPE (dest
), ptr
, size
, call
, nonalloc
;
844 tree cond
, then_b
, else_b
;
845 stmtblock_t block
, cond_block
, cond_block2
, inner_block
;
847 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
848 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
849 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
850 || !POINTER_TYPE_P (type
)))
852 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
854 gfc_start_block (&block
);
855 /* First dealloc any allocatable components in DEST. */
856 tree tem
= gfc_walk_alloc_comps (dest
, NULL_TREE
,
857 OMP_CLAUSE_DECL (clause
),
858 WALK_ALLOC_COMPS_DTOR
);
859 gfc_add_expr_to_block (&block
, tem
);
860 /* Then copy over toplevel data. */
861 gfc_add_modify (&block
, dest
, src
);
862 /* Finally allocate any allocatable components and copy. */
863 tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
864 WALK_ALLOC_COMPS_COPY_CTOR
);
865 gfc_add_expr_to_block (&block
, tem
);
866 return gfc_finish_block (&block
);
869 return build2_v (MODIFY_EXPR
, dest
, src
);
872 gfc_start_block (&block
);
874 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
876 then_b
= gfc_walk_alloc_comps (dest
, NULL_TREE
, OMP_CLAUSE_DECL (clause
),
877 WALK_ALLOC_COMPS_DTOR
);
878 tree tem
= fold_convert (pvoid_type_node
,
879 GFC_DESCRIPTOR_TYPE_P (type
)
880 ? gfc_conv_descriptor_data_get (dest
) : dest
);
881 tem
= unshare_expr (tem
);
882 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
883 tem
, null_pointer_node
);
884 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
885 then_b
, build_empty_stmt (input_location
));
886 gfc_add_expr_to_block (&block
, tem
);
889 gfc_init_block (&cond_block
);
891 if (GFC_DESCRIPTOR_TYPE_P (type
))
893 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
894 size
= gfc_conv_descriptor_ubound_get (src
, rank
);
895 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
897 gfc_conv_descriptor_lbound_get (src
, rank
));
898 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
899 size
, gfc_index_one_node
);
900 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
901 size
= fold_build2_loc (input_location
, MULT_EXPR
,
902 gfc_array_index_type
, size
,
903 gfc_conv_descriptor_stride_get (src
, rank
));
904 tree esize
= fold_convert (gfc_array_index_type
,
905 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
906 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
908 size
= unshare_expr (size
);
909 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
913 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
914 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
916 tree destptr
= GFC_DESCRIPTOR_TYPE_P (type
)
917 ? gfc_conv_descriptor_data_get (dest
) : dest
;
918 destptr
= unshare_expr (destptr
);
919 destptr
= fold_convert (pvoid_type_node
, destptr
);
920 gfc_add_modify (&cond_block
, ptr
, destptr
);
922 nonalloc
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
923 destptr
, null_pointer_node
);
925 if (GFC_DESCRIPTOR_TYPE_P (type
))
928 for (i
= 0; i
< GFC_TYPE_ARRAY_RANK (type
); i
++)
930 tree rank
= gfc_rank_cst
[i
];
931 tree tem
= gfc_conv_descriptor_ubound_get (src
, rank
);
932 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
933 gfc_array_index_type
, tem
,
934 gfc_conv_descriptor_lbound_get (src
, rank
));
935 tem
= fold_build2_loc (input_location
, PLUS_EXPR
,
936 gfc_array_index_type
, tem
,
937 gfc_conv_descriptor_lbound_get (dest
, rank
));
938 tem
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
939 tem
, gfc_conv_descriptor_ubound_get (dest
,
941 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
942 logical_type_node
, cond
, tem
);
946 gfc_init_block (&cond_block2
);
948 if (GFC_DESCRIPTOR_TYPE_P (type
))
950 gfc_init_block (&inner_block
);
951 gfc_allocate_using_malloc (&inner_block
, ptr
, size
, NULL_TREE
);
952 then_b
= gfc_finish_block (&inner_block
);
954 gfc_init_block (&inner_block
);
955 gfc_add_modify (&inner_block
, ptr
,
956 gfc_call_realloc (&inner_block
, ptr
, size
));
957 else_b
= gfc_finish_block (&inner_block
);
959 gfc_add_expr_to_block (&cond_block2
,
960 build3_loc (input_location
, COND_EXPR
,
962 unshare_expr (nonalloc
),
964 gfc_add_modify (&cond_block2
, dest
, src
);
965 gfc_conv_descriptor_data_set (&cond_block2
, unshare_expr (dest
), ptr
);
969 gfc_allocate_using_malloc (&cond_block2
, ptr
, size
, NULL_TREE
);
970 gfc_add_modify (&cond_block2
, unshare_expr (dest
),
971 fold_convert (type
, ptr
));
973 then_b
= gfc_finish_block (&cond_block2
);
974 else_b
= build_empty_stmt (input_location
);
976 gfc_add_expr_to_block (&cond_block
,
977 build3_loc (input_location
, COND_EXPR
,
978 void_type_node
, unshare_expr (cond
),
981 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
982 ? gfc_conv_descriptor_data_get (src
) : src
;
983 srcptr
= unshare_expr (srcptr
);
984 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
985 call
= build_call_expr_loc (input_location
,
986 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
988 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
989 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
991 tree tem
= gfc_walk_alloc_comps (src
, dest
,
992 OMP_CLAUSE_DECL (clause
),
993 WALK_ALLOC_COMPS_COPY_CTOR
);
994 gfc_add_expr_to_block (&cond_block
, tem
);
996 then_b
= gfc_finish_block (&cond_block
);
998 if (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_COPYIN
)
1000 gfc_init_block (&cond_block
);
1001 if (GFC_DESCRIPTOR_TYPE_P (type
))
1003 tree tmp
= gfc_conv_descriptor_data_get (unshare_expr (dest
));
1004 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
1005 NULL_TREE
, NULL_TREE
, true, NULL
,
1006 GFC_CAF_COARRAY_NOCOARRAY
);
1007 gfc_add_expr_to_block (&cond_block
, tmp
);
1011 destptr
= gfc_evaluate_now (destptr
, &cond_block
);
1012 gfc_add_expr_to_block (&cond_block
, gfc_call_free (destptr
));
1013 gfc_add_modify (&cond_block
, unshare_expr (dest
),
1014 build_zero_cst (TREE_TYPE (dest
)));
1016 else_b
= gfc_finish_block (&cond_block
);
1018 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1019 unshare_expr (srcptr
), null_pointer_node
);
1020 gfc_add_expr_to_block (&block
,
1021 build3_loc (input_location
, COND_EXPR
,
1022 void_type_node
, cond
,
1026 gfc_add_expr_to_block (&block
, then_b
);
1028 return gfc_finish_block (&block
);
1032 gfc_omp_linear_clause_add_loop (stmtblock_t
*block
, tree dest
, tree src
,
1033 tree add
, tree nelems
)
1035 stmtblock_t tmpblock
;
1036 tree desta
, srca
, index
= gfc_create_var (gfc_array_index_type
, "S");
1037 nelems
= gfc_evaluate_now (nelems
, block
);
1039 gfc_init_block (&tmpblock
);
1040 if (TREE_CODE (TREE_TYPE (dest
)) == ARRAY_TYPE
)
1042 desta
= gfc_build_array_ref (dest
, index
, NULL
);
1043 srca
= gfc_build_array_ref (src
, index
, NULL
);
1047 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest
)));
1048 tree idx
= fold_build2 (MULT_EXPR
, sizetype
,
1049 fold_convert (sizetype
, index
),
1050 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest
))));
1051 desta
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1052 TREE_TYPE (dest
), dest
,
1054 srca
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
1055 TREE_TYPE (src
), src
,
1058 gfc_add_modify (&tmpblock
, desta
,
1059 fold_build2 (PLUS_EXPR
, TREE_TYPE (desta
),
1063 gfc_init_loopinfo (&loop
);
1065 loop
.from
[0] = gfc_index_zero_node
;
1066 loop
.loopvar
[0] = index
;
1067 loop
.to
[0] = nelems
;
1068 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
1069 gfc_add_block_to_block (block
, &loop
.pre
);
1072 /* Build and return code for a constructor of DEST that initializes
1073 it to SRC plus ADD (ADD is scalar integer). */
1076 gfc_omp_clause_linear_ctor (tree clause
, tree dest
, tree src
, tree add
)
1078 tree type
= TREE_TYPE (dest
), ptr
, size
, nelems
= NULL_TREE
;
1081 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
1083 gfc_start_block (&block
);
1084 add
= gfc_evaluate_now (add
, &block
);
1086 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1087 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1088 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1089 || !POINTER_TYPE_P (type
)))
1091 bool compute_nelts
= false;
1092 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
1093 if (!TYPE_DOMAIN (type
)
1094 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
1095 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
1096 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
1097 compute_nelts
= true;
1098 else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
1100 tree a
= DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
1101 if (lookup_attribute ("omp dummy var", a
))
1102 compute_nelts
= true;
1106 nelems
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
1107 TYPE_SIZE_UNIT (type
),
1108 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1109 nelems
= size_binop (MINUS_EXPR
, nelems
, size_one_node
);
1112 nelems
= array_type_nelts (type
);
1113 nelems
= fold_convert (gfc_array_index_type
, nelems
);
1115 gfc_omp_linear_clause_add_loop (&block
, dest
, src
, add
, nelems
);
1116 return gfc_finish_block (&block
);
1119 /* Allocatable arrays in LINEAR clauses need to be allocated
1120 and copied from SRC. */
1121 gfc_add_modify (&block
, dest
, src
);
1122 if (GFC_DESCRIPTOR_TYPE_P (type
))
1124 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
1125 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
1126 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1128 gfc_conv_descriptor_lbound_get (dest
, rank
));
1129 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1130 size
, gfc_index_one_node
);
1131 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
1132 size
= fold_build2_loc (input_location
, MULT_EXPR
,
1133 gfc_array_index_type
, size
,
1134 gfc_conv_descriptor_stride_get (dest
, rank
));
1135 tree esize
= fold_convert (gfc_array_index_type
,
1136 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
1137 nelems
= gfc_evaluate_now (unshare_expr (size
), &block
);
1138 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
1139 nelems
, unshare_expr (esize
));
1140 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
1142 nelems
= fold_build2_loc (input_location
, MINUS_EXPR
,
1143 gfc_array_index_type
, nelems
,
1144 gfc_index_one_node
);
1147 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
1148 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
1149 gfc_allocate_using_malloc (&block
, ptr
, size
, NULL_TREE
);
1150 if (GFC_DESCRIPTOR_TYPE_P (type
))
1152 gfc_conv_descriptor_data_set (&block
, unshare_expr (dest
), ptr
);
1153 tree etype
= gfc_get_element_type (type
);
1154 ptr
= fold_convert (build_pointer_type (etype
), ptr
);
1155 tree srcptr
= gfc_conv_descriptor_data_get (unshare_expr (src
));
1156 srcptr
= fold_convert (build_pointer_type (etype
), srcptr
);
1157 gfc_omp_linear_clause_add_loop (&block
, ptr
, srcptr
, add
, nelems
);
1161 gfc_add_modify (&block
, unshare_expr (dest
),
1162 fold_convert (TREE_TYPE (dest
), ptr
));
1163 ptr
= fold_convert (TREE_TYPE (dest
), ptr
);
1164 tree dstm
= build_fold_indirect_ref (ptr
);
1165 tree srcm
= build_fold_indirect_ref (unshare_expr (src
));
1166 gfc_add_modify (&block
, dstm
,
1167 fold_build2 (PLUS_EXPR
, TREE_TYPE (add
), srcm
, add
));
1169 return gfc_finish_block (&block
);
1172 /* Build and return code destructing DECL. Return NULL if nothing
1176 gfc_omp_clause_dtor (tree clause
, tree decl
)
1178 tree type
= TREE_TYPE (decl
), tem
;
1180 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
1181 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
1182 && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
))
1183 || !POINTER_TYPE_P (type
)))
1185 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1186 return gfc_walk_alloc_comps (decl
, NULL_TREE
,
1187 OMP_CLAUSE_DECL (clause
),
1188 WALK_ALLOC_COMPS_DTOR
);
1192 if (GFC_DESCRIPTOR_TYPE_P (type
))
1194 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
1195 to be deallocated if they were allocated. */
1196 tem
= gfc_conv_descriptor_data_get (decl
);
1197 tem
= gfc_deallocate_with_status (tem
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
1198 NULL_TREE
, true, NULL
,
1199 GFC_CAF_COARRAY_NOCOARRAY
);
1202 tem
= gfc_call_free (decl
);
1203 tem
= gfc_omp_unshare_expr (tem
);
1205 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1210 gfc_init_block (&block
);
1211 gfc_add_expr_to_block (&block
,
1212 gfc_walk_alloc_comps (decl
, NULL_TREE
,
1213 OMP_CLAUSE_DECL (clause
),
1214 WALK_ALLOC_COMPS_DTOR
));
1215 gfc_add_expr_to_block (&block
, tem
);
1216 then_b
= gfc_finish_block (&block
);
1218 tem
= fold_convert (pvoid_type_node
,
1219 GFC_DESCRIPTOR_TYPE_P (type
)
1220 ? gfc_conv_descriptor_data_get (decl
) : decl
);
1221 tem
= unshare_expr (tem
);
1222 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1223 tem
, null_pointer_node
);
1224 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1225 then_b
, build_empty_stmt (input_location
));
1230 /* Build a conditional expression in BLOCK. If COND_VAL is not
1231 null, then the block THEN_B is executed, otherwise ELSE_VAL
1232 is assigned to VAL. */
1235 gfc_build_cond_assign (stmtblock_t
*block
, tree val
, tree cond_val
,
1236 tree then_b
, tree else_val
)
1238 stmtblock_t cond_block
;
1239 tree else_b
= NULL_TREE
;
1240 tree val_ty
= TREE_TYPE (val
);
1244 gfc_init_block (&cond_block
);
1245 gfc_add_modify (&cond_block
, val
, fold_convert (val_ty
, else_val
));
1246 else_b
= gfc_finish_block (&cond_block
);
1248 gfc_add_expr_to_block (block
,
1249 build3_loc (input_location
, COND_EXPR
, void_type_node
,
1250 cond_val
, then_b
, else_b
));
1253 /* Build a conditional expression in BLOCK, returning a temporary
1254 variable containing the result. If COND_VAL is not null, then
1255 THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
1260 gfc_build_cond_assign_expr (stmtblock_t
*block
, tree cond_val
,
1261 tree then_val
, tree else_val
)
1264 tree val_ty
= TREE_TYPE (then_val
);
1265 stmtblock_t cond_block
;
1267 val
= create_tmp_var (val_ty
);
1269 gfc_init_block (&cond_block
);
1270 gfc_add_modify (&cond_block
, val
, then_val
);
1271 tree then_b
= gfc_finish_block (&cond_block
);
1273 gfc_build_cond_assign (block
, val
, cond_val
, then_b
, else_val
);
1279 gfc_omp_finish_clause (tree c
, gimple_seq
*pre_p
, bool openacc
)
1281 if (OMP_CLAUSE_CODE (c
) != OMP_CLAUSE_MAP
)
1284 tree decl
= OMP_CLAUSE_DECL (c
);
1286 /* Assumed-size arrays can't be mapped implicitly, they have to be
1287 mapped explicitly using array sections. */
1288 if (TREE_CODE (decl
) == PARM_DECL
1289 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
1290 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
1291 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
1292 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
1295 error_at (OMP_CLAUSE_LOCATION (c
),
1296 "implicit mapping of assumed size array %qD", decl
);
1300 tree c2
= NULL_TREE
, c3
= NULL_TREE
, c4
= NULL_TREE
;
1301 tree present
= gfc_omp_check_optional_argument (decl
, true);
1302 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
1304 if (!gfc_omp_privatize_by_reference (decl
)
1305 && !GFC_DECL_GET_SCALAR_POINTER (decl
)
1306 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1307 && !GFC_DECL_CRAY_POINTEE (decl
)
1308 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
1310 tree orig_decl
= decl
;
1312 c4
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1313 OMP_CLAUSE_SET_MAP_KIND (c4
, GOMP_MAP_POINTER
);
1314 OMP_CLAUSE_DECL (c4
) = decl
;
1315 OMP_CLAUSE_SIZE (c4
) = size_int (0);
1316 decl
= build_fold_indirect_ref (decl
);
1318 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1319 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1321 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1322 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_POINTER
);
1323 OMP_CLAUSE_DECL (c2
) = decl
;
1324 OMP_CLAUSE_SIZE (c2
) = size_int (0);
1327 gfc_start_block (&block
);
1329 ptr
= gfc_build_cond_assign_expr (&block
, present
, decl
,
1331 gimplify_and_add (gfc_finish_block (&block
), pre_p
);
1332 ptr
= build_fold_indirect_ref (ptr
);
1333 OMP_CLAUSE_DECL (c
) = ptr
;
1334 OMP_CLAUSE_SIZE (c
) = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
1338 OMP_CLAUSE_DECL (c
) = decl
;
1339 OMP_CLAUSE_SIZE (c
) = NULL_TREE
;
1341 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1342 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1343 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1345 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1346 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1347 OMP_CLAUSE_DECL (c3
) = unshare_expr (decl
);
1348 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1349 decl
= build_fold_indirect_ref (decl
);
1350 OMP_CLAUSE_DECL (c
) = decl
;
1353 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1356 gfc_start_block (&block
);
1357 tree type
= TREE_TYPE (decl
);
1358 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1360 /* OpenMP: automatically map pointer targets with the pointer;
1361 hence, always update the descriptor/pointer itself.
1362 NOTE: This also remaps the pointer for allocatable arrays with
1363 'target' attribute which also don't have the 'restrict' qualifier. */
1364 bool always_modifier
= false;
1367 && !(TYPE_QUALS (TREE_TYPE (ptr
)) & TYPE_QUAL_RESTRICT
))
1368 always_modifier
= true;
1371 ptr
= gfc_build_cond_assign_expr (&block
, present
, ptr
,
1373 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
1374 ptr
= build_fold_indirect_ref (ptr
);
1375 OMP_CLAUSE_DECL (c
) = ptr
;
1376 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1377 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_TO_PSET
);
1380 ptr
= create_tmp_var (TREE_TYPE (TREE_OPERAND (decl
, 0)));
1381 gfc_add_modify (&block
, ptr
, TREE_OPERAND (decl
, 0));
1383 OMP_CLAUSE_DECL (c2
) = build_fold_indirect_ref (ptr
);
1386 OMP_CLAUSE_DECL (c2
) = decl
;
1387 OMP_CLAUSE_SIZE (c2
) = TYPE_SIZE_UNIT (type
);
1388 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1389 OMP_CLAUSE_SET_MAP_KIND (c3
, always_modifier
? GOMP_MAP_ALWAYS_POINTER
1390 : GOMP_MAP_POINTER
);
1393 ptr
= gfc_conv_descriptor_data_get (decl
);
1394 ptr
= gfc_build_addr_expr (NULL
, ptr
);
1395 ptr
= gfc_build_cond_assign_expr (&block
, present
,
1396 ptr
, null_pointer_node
);
1397 ptr
= build_fold_indirect_ref (ptr
);
1398 OMP_CLAUSE_DECL (c3
) = ptr
;
1401 OMP_CLAUSE_DECL (c3
) = gfc_conv_descriptor_data_get (decl
);
1402 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1403 tree size
= create_tmp_var (gfc_array_index_type
);
1404 tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
1405 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
1406 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
1407 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
1409 stmtblock_t cond_block
;
1410 tree tem
, then_b
, else_b
, zero
, cond
;
1412 gfc_init_block (&cond_block
);
1413 tem
= gfc_full_array_size (&cond_block
, decl
,
1414 GFC_TYPE_ARRAY_RANK (type
));
1415 gfc_add_modify (&cond_block
, size
, tem
);
1416 gfc_add_modify (&cond_block
, size
,
1417 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1419 then_b
= gfc_finish_block (&cond_block
);
1420 gfc_init_block (&cond_block
);
1421 zero
= build_int_cst (gfc_array_index_type
, 0);
1422 gfc_add_modify (&cond_block
, size
, zero
);
1423 else_b
= gfc_finish_block (&cond_block
);
1424 tem
= gfc_conv_descriptor_data_get (decl
);
1425 tem
= fold_convert (pvoid_type_node
, tem
);
1426 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1427 boolean_type_node
, tem
, null_pointer_node
);
1430 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1431 boolean_type_node
, present
, cond
);
1433 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1434 void_type_node
, cond
,
1439 stmtblock_t cond_block
;
1442 gfc_init_block (&cond_block
);
1443 gfc_add_modify (&cond_block
, size
,
1444 gfc_full_array_size (&cond_block
, decl
,
1445 GFC_TYPE_ARRAY_RANK (type
)));
1446 gfc_add_modify (&cond_block
, size
,
1447 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1449 then_b
= gfc_finish_block (&cond_block
);
1451 gfc_build_cond_assign (&block
, size
, present
, then_b
,
1452 build_int_cst (gfc_array_index_type
, 0));
1456 gfc_add_modify (&block
, size
,
1457 gfc_full_array_size (&block
, decl
,
1458 GFC_TYPE_ARRAY_RANK (type
)));
1459 gfc_add_modify (&block
, size
,
1460 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1463 OMP_CLAUSE_SIZE (c
) = size
;
1464 tree stmt
= gfc_finish_block (&block
);
1465 gimplify_and_add (stmt
, pre_p
);
1468 if (OMP_CLAUSE_SIZE (c
) == NULL_TREE
)
1470 = DECL_P (decl
) ? DECL_SIZE_UNIT (decl
)
1471 : TYPE_SIZE_UNIT (TREE_TYPE (decl
));
1474 OMP_CLAUSE_CHAIN (c2
) = OMP_CLAUSE_CHAIN (last
);
1475 OMP_CLAUSE_CHAIN (last
) = c2
;
1480 OMP_CLAUSE_CHAIN (c3
) = OMP_CLAUSE_CHAIN (last
);
1481 OMP_CLAUSE_CHAIN (last
) = c3
;
1486 OMP_CLAUSE_CHAIN (c4
) = OMP_CLAUSE_CHAIN (last
);
1487 OMP_CLAUSE_CHAIN (last
) = c4
;
1492 /* Return true if DECL is a scalar variable (for the purpose of
1493 implicit firstprivatization). */
1496 gfc_omp_scalar_p (tree decl
)
1498 tree type
= TREE_TYPE (decl
);
1499 if (TREE_CODE (type
) == REFERENCE_TYPE
)
1500 type
= TREE_TYPE (type
);
1501 if (TREE_CODE (type
) == POINTER_TYPE
)
1503 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1504 || GFC_DECL_GET_SCALAR_POINTER (decl
))
1505 type
= TREE_TYPE (type
);
1506 if (GFC_ARRAY_TYPE_P (type
)
1507 || GFC_CLASS_TYPE_P (type
))
1510 if ((TREE_CODE (type
) == ARRAY_TYPE
|| TREE_CODE (type
) == INTEGER_TYPE
)
1511 && TYPE_STRING_FLAG (type
))
1513 if (INTEGRAL_TYPE_P (type
)
1514 || SCALAR_FLOAT_TYPE_P (type
)
1515 || COMPLEX_FLOAT_TYPE_P (type
))
1521 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1522 disregarded in OpenMP construct, because it is going to be
1523 remapped during OpenMP lowering. SHARED is true if DECL
1524 is going to be shared, false if it is going to be privatized. */
1527 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
1529 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1530 && DECL_HAS_VALUE_EXPR_P (decl
))
1532 tree value
= DECL_VALUE_EXPR (decl
);
1534 if (TREE_CODE (value
) == COMPONENT_REF
1535 && VAR_P (TREE_OPERAND (value
, 0))
1536 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1538 /* If variable in COMMON or EQUIVALENCE is privatized, return
1539 true, as just that variable is supposed to be privatized,
1540 not the whole COMMON or whole EQUIVALENCE.
1541 For shared variables in COMMON or EQUIVALENCE, let them be
1542 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1543 from the same COMMON or EQUIVALENCE just one sharing of the
1544 whole COMMON or EQUIVALENCE is enough. */
1549 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
1555 /* Return true if DECL that is shared iff SHARED is true should
1556 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1560 gfc_omp_private_debug_clause (tree decl
, bool shared
)
1562 if (GFC_DECL_CRAY_POINTEE (decl
))
1565 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1566 && DECL_HAS_VALUE_EXPR_P (decl
))
1568 tree value
= DECL_VALUE_EXPR (decl
);
1570 if (TREE_CODE (value
) == COMPONENT_REF
1571 && VAR_P (TREE_OPERAND (value
, 0))
1572 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1579 /* Register language specific type size variables as potentially OpenMP
1580 firstprivate variables. */
1583 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
1585 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
1589 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
1590 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
1592 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
1593 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
1594 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
1596 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
1597 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
1603 gfc_trans_add_clause (tree node
, tree tail
)
1605 OMP_CLAUSE_CHAIN (node
) = tail
;
1610 gfc_trans_omp_variable (gfc_symbol
*sym
, bool declare_simd
)
1615 gfc_symbol
*proc_sym
;
1616 gfc_formal_arglist
*f
;
1618 gcc_assert (sym
->attr
.dummy
);
1619 proc_sym
= sym
->ns
->proc_name
;
1620 if (proc_sym
->attr
.entry_master
)
1622 if (gfc_return_by_reference (proc_sym
))
1625 if (proc_sym
->ts
.type
== BT_CHARACTER
)
1628 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
1634 return build_int_cst (integer_type_node
, cnt
);
1637 tree t
= gfc_get_symbol_decl (sym
);
1641 bool alternate_entry
;
1644 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1645 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1646 && sym
->result
== sym
;
1647 entry_master
= sym
->attr
.result
1648 && sym
->ns
->proc_name
->attr
.entry_master
1649 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1650 parent_decl
= current_function_decl
1651 ? DECL_CONTEXT (current_function_decl
) : NULL_TREE
;
1653 if ((t
== parent_decl
&& return_value
)
1654 || (sym
->ns
&& sym
->ns
->proc_name
1655 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1656 && (alternate_entry
|| entry_master
)))
1661 /* Special case for assigning the return value of a function.
1662 Self recursive functions must have an explicit return value. */
1663 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
1664 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1666 /* Similarly for alternate entry points. */
1667 else if (alternate_entry
1668 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1671 gfc_entry_list
*el
= NULL
;
1673 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1676 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1681 else if (entry_master
1682 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1684 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1690 gfc_trans_omp_variable_list (enum omp_clause_code code
,
1691 gfc_omp_namelist
*namelist
, tree list
,
1694 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1695 if (namelist
->sym
->attr
.referenced
|| declare_simd
)
1697 tree t
= gfc_trans_omp_variable (namelist
->sym
, declare_simd
);
1698 if (t
!= error_mark_node
)
1700 tree node
= build_omp_clause (input_location
, code
);
1701 OMP_CLAUSE_DECL (node
) = t
;
1702 list
= gfc_trans_add_clause (node
, list
);
1704 if (code
== OMP_CLAUSE_LASTPRIVATE
1705 && namelist
->u
.lastprivate_conditional
)
1706 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node
) = 1;
1712 struct omp_udr_find_orig_data
1714 gfc_omp_udr
*omp_udr
;
1719 omp_udr_find_orig (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1722 struct omp_udr_find_orig_data
*cd
= (struct omp_udr_find_orig_data
*) data
;
1723 if ((*e
)->expr_type
== EXPR_VARIABLE
1724 && (*e
)->symtree
->n
.sym
== cd
->omp_udr
->omp_orig
)
1725 cd
->omp_orig_seen
= true;
1731 gfc_trans_omp_array_reduction_or_udr (tree c
, gfc_omp_namelist
*n
, locus where
)
1733 gfc_symbol
*sym
= n
->sym
;
1734 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
1735 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
1736 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
1737 gfc_symbol omp_var_copy
[4];
1738 gfc_expr
*e1
, *e2
, *e3
, *e4
;
1740 tree decl
, backend_decl
, stmt
, type
, outer_decl
;
1741 locus old_loc
= gfc_current_locus
;
1744 gfc_omp_udr
*udr
= n
->udr
? n
->udr
->udr
: NULL
;
1746 decl
= OMP_CLAUSE_DECL (c
);
1747 gfc_current_locus
= where
;
1748 type
= TREE_TYPE (decl
);
1749 outer_decl
= create_tmp_var_raw (type
);
1750 if (TREE_CODE (decl
) == PARM_DECL
1751 && TREE_CODE (type
) == REFERENCE_TYPE
1752 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
))
1753 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type
)) == GFC_ARRAY_ALLOCATABLE
)
1755 decl
= build_fold_indirect_ref (decl
);
1756 type
= TREE_TYPE (type
);
1759 /* Create a fake symbol for init value. */
1760 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
1761 init_val_sym
.ns
= sym
->ns
;
1762 init_val_sym
.name
= sym
->name
;
1763 init_val_sym
.ts
= sym
->ts
;
1764 init_val_sym
.attr
.referenced
= 1;
1765 init_val_sym
.declared_at
= where
;
1766 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
1767 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1768 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
1769 else if (udr
->initializer_ns
)
1770 backend_decl
= NULL
;
1772 switch (sym
->ts
.type
)
1778 backend_decl
= build_zero_cst (gfc_sym_type (&init_val_sym
));
1781 backend_decl
= NULL_TREE
;
1784 init_val_sym
.backend_decl
= backend_decl
;
1786 /* Create a fake symbol for the outer array reference. */
1789 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
1790 outer_sym
.attr
.dummy
= 0;
1791 outer_sym
.attr
.result
= 0;
1792 outer_sym
.attr
.flavor
= FL_VARIABLE
;
1793 outer_sym
.backend_decl
= outer_decl
;
1794 if (decl
!= OMP_CLAUSE_DECL (c
))
1795 outer_sym
.backend_decl
= build_fold_indirect_ref (outer_decl
);
1797 /* Create fake symtrees for it. */
1798 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
1799 symtree1
->n
.sym
= sym
;
1800 gcc_assert (symtree1
== root1
);
1802 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
1803 symtree2
->n
.sym
= &init_val_sym
;
1804 gcc_assert (symtree2
== root2
);
1806 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
1807 symtree3
->n
.sym
= &outer_sym
;
1808 gcc_assert (symtree3
== root3
);
1810 memset (omp_var_copy
, 0, sizeof omp_var_copy
);
1813 omp_var_copy
[0] = *udr
->omp_out
;
1814 omp_var_copy
[1] = *udr
->omp_in
;
1815 *udr
->omp_out
= outer_sym
;
1816 *udr
->omp_in
= *sym
;
1817 if (udr
->initializer_ns
)
1819 omp_var_copy
[2] = *udr
->omp_priv
;
1820 omp_var_copy
[3] = *udr
->omp_orig
;
1821 *udr
->omp_priv
= *sym
;
1822 *udr
->omp_orig
= outer_sym
;
1826 /* Create expressions. */
1827 e1
= gfc_get_expr ();
1828 e1
->expr_type
= EXPR_VARIABLE
;
1830 e1
->symtree
= symtree1
;
1832 if (sym
->attr
.dimension
)
1834 e1
->ref
= ref
= gfc_get_ref ();
1835 ref
->type
= REF_ARRAY
;
1836 ref
->u
.ar
.where
= where
;
1837 ref
->u
.ar
.as
= sym
->as
;
1838 ref
->u
.ar
.type
= AR_FULL
;
1839 ref
->u
.ar
.dimen
= 0;
1841 t
= gfc_resolve_expr (e1
);
1845 if (backend_decl
!= NULL_TREE
)
1847 e2
= gfc_get_expr ();
1848 e2
->expr_type
= EXPR_VARIABLE
;
1850 e2
->symtree
= symtree2
;
1852 t
= gfc_resolve_expr (e2
);
1855 else if (udr
->initializer_ns
== NULL
)
1857 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
1858 e2
= gfc_default_initializer (&sym
->ts
);
1860 t
= gfc_resolve_expr (e2
);
1863 else if (n
->udr
->initializer
->op
== EXEC_ASSIGN
)
1865 e2
= gfc_copy_expr (n
->udr
->initializer
->expr2
);
1866 t
= gfc_resolve_expr (e2
);
1869 if (udr
&& udr
->initializer_ns
)
1871 struct omp_udr_find_orig_data cd
;
1873 cd
.omp_orig_seen
= false;
1874 gfc_code_walker (&n
->udr
->initializer
,
1875 gfc_dummy_code_callback
, omp_udr_find_orig
, &cd
);
1876 if (cd
.omp_orig_seen
)
1877 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c
) = 1;
1880 e3
= gfc_copy_expr (e1
);
1881 e3
->symtree
= symtree3
;
1882 t
= gfc_resolve_expr (e3
);
1887 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
1891 e4
= gfc_add (e3
, e1
);
1894 e4
= gfc_multiply (e3
, e1
);
1896 case TRUTH_ANDIF_EXPR
:
1897 e4
= gfc_and (e3
, e1
);
1899 case TRUTH_ORIF_EXPR
:
1900 e4
= gfc_or (e3
, e1
);
1903 e4
= gfc_eqv (e3
, e1
);
1906 e4
= gfc_neqv (e3
, e1
);
1924 if (n
->udr
->combiner
->op
== EXEC_ASSIGN
)
1927 e3
= gfc_copy_expr (n
->udr
->combiner
->expr1
);
1928 e4
= gfc_copy_expr (n
->udr
->combiner
->expr2
);
1929 t
= gfc_resolve_expr (e3
);
1931 t
= gfc_resolve_expr (e4
);
1940 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
1941 intrinsic_sym
.ns
= sym
->ns
;
1942 intrinsic_sym
.name
= iname
;
1943 intrinsic_sym
.ts
= sym
->ts
;
1944 intrinsic_sym
.attr
.referenced
= 1;
1945 intrinsic_sym
.attr
.intrinsic
= 1;
1946 intrinsic_sym
.attr
.function
= 1;
1947 intrinsic_sym
.attr
.implicit_type
= 1;
1948 intrinsic_sym
.result
= &intrinsic_sym
;
1949 intrinsic_sym
.declared_at
= where
;
1951 symtree4
= gfc_new_symtree (&root4
, iname
);
1952 symtree4
->n
.sym
= &intrinsic_sym
;
1953 gcc_assert (symtree4
== root4
);
1955 e4
= gfc_get_expr ();
1956 e4
->expr_type
= EXPR_FUNCTION
;
1958 e4
->symtree
= symtree4
;
1959 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
1960 e4
->value
.function
.actual
->expr
= e3
;
1961 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1962 e4
->value
.function
.actual
->next
->expr
= e1
;
1964 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1966 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1967 e1
= gfc_copy_expr (e1
);
1968 e3
= gfc_copy_expr (e3
);
1969 t
= gfc_resolve_expr (e4
);
1973 /* Create the init statement list. */
1976 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
1978 stmt
= gfc_trans_call (n
->udr
->initializer
, false,
1979 NULL_TREE
, NULL_TREE
, false);
1980 if (TREE_CODE (stmt
) != BIND_EXPR
)
1981 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1984 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
1986 /* Create the merge statement list. */
1989 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
1991 stmt
= gfc_trans_call (n
->udr
->combiner
, false,
1992 NULL_TREE
, NULL_TREE
, false);
1993 if (TREE_CODE (stmt
) != BIND_EXPR
)
1994 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1997 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
1999 /* And stick the placeholder VAR_DECL into the clause as well. */
2000 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_decl
;
2002 gfc_current_locus
= old_loc
;
2015 gfc_free_array_spec (outer_sym
.as
);
2019 *udr
->omp_out
= omp_var_copy
[0];
2020 *udr
->omp_in
= omp_var_copy
[1];
2021 if (udr
->initializer_ns
)
2023 *udr
->omp_priv
= omp_var_copy
[2];
2024 *udr
->omp_orig
= omp_var_copy
[3];
2030 gfc_trans_omp_reduction_list (gfc_omp_namelist
*namelist
, tree list
,
2031 locus where
, bool mark_addressable
)
2033 for (; namelist
!= NULL
; namelist
= namelist
->next
)
2034 if (namelist
->sym
->attr
.referenced
)
2036 tree t
= gfc_trans_omp_variable (namelist
->sym
, false);
2037 if (t
!= error_mark_node
)
2039 tree node
= build_omp_clause (gfc_get_location (&namelist
->where
),
2040 OMP_CLAUSE_REDUCTION
);
2041 OMP_CLAUSE_DECL (node
) = t
;
2042 if (mark_addressable
)
2043 TREE_ADDRESSABLE (t
) = 1;
2044 switch (namelist
->u
.reduction_op
)
2046 case OMP_REDUCTION_PLUS
:
2047 OMP_CLAUSE_REDUCTION_CODE (node
) = PLUS_EXPR
;
2049 case OMP_REDUCTION_MINUS
:
2050 OMP_CLAUSE_REDUCTION_CODE (node
) = MINUS_EXPR
;
2052 case OMP_REDUCTION_TIMES
:
2053 OMP_CLAUSE_REDUCTION_CODE (node
) = MULT_EXPR
;
2055 case OMP_REDUCTION_AND
:
2056 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ANDIF_EXPR
;
2058 case OMP_REDUCTION_OR
:
2059 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ORIF_EXPR
;
2061 case OMP_REDUCTION_EQV
:
2062 OMP_CLAUSE_REDUCTION_CODE (node
) = EQ_EXPR
;
2064 case OMP_REDUCTION_NEQV
:
2065 OMP_CLAUSE_REDUCTION_CODE (node
) = NE_EXPR
;
2067 case OMP_REDUCTION_MAX
:
2068 OMP_CLAUSE_REDUCTION_CODE (node
) = MAX_EXPR
;
2070 case OMP_REDUCTION_MIN
:
2071 OMP_CLAUSE_REDUCTION_CODE (node
) = MIN_EXPR
;
2073 case OMP_REDUCTION_IAND
:
2074 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_AND_EXPR
;
2076 case OMP_REDUCTION_IOR
:
2077 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_IOR_EXPR
;
2079 case OMP_REDUCTION_IEOR
:
2080 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_XOR_EXPR
;
2082 case OMP_REDUCTION_USER
:
2083 OMP_CLAUSE_REDUCTION_CODE (node
) = ERROR_MARK
;
2088 if (namelist
->sym
->attr
.dimension
2089 || namelist
->u
.reduction_op
== OMP_REDUCTION_USER
2090 || namelist
->sym
->attr
.allocatable
)
2091 gfc_trans_omp_array_reduction_or_udr (node
, namelist
, where
);
2092 list
= gfc_trans_add_clause (node
, list
);
2099 gfc_convert_expr_to_tree (stmtblock_t
*block
, gfc_expr
*expr
)
2104 gfc_init_se (&se
, NULL
);
2105 gfc_conv_expr (&se
, expr
);
2106 gfc_add_block_to_block (block
, &se
.pre
);
2107 result
= gfc_evaluate_now (se
.expr
, block
);
2108 gfc_add_block_to_block (block
, &se
.post
);
2113 static vec
<tree
, va_heap
, vl_embed
> *doacross_steps
;
2116 /* Translate an array section or array element. */
2119 gfc_trans_omp_array_section (stmtblock_t
*block
, gfc_omp_namelist
*n
,
2120 tree decl
, bool element
, gomp_map_kind ptr_kind
,
2121 tree
&node
, tree
&node2
, tree
&node3
, tree
&node4
)
2125 tree elemsz
= NULL_TREE
;
2127 gfc_init_se (&se
, NULL
);
2131 gfc_conv_expr_reference (&se
, n
->expr
);
2132 gfc_add_block_to_block (block
, &se
.pre
);
2134 OMP_CLAUSE_SIZE (node
) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr
)));
2135 elemsz
= OMP_CLAUSE_SIZE (node
);
2139 gfc_conv_expr_descriptor (&se
, n
->expr
);
2140 ptr
= gfc_conv_array_data (se
.expr
);
2141 tree type
= TREE_TYPE (se
.expr
);
2142 gfc_add_block_to_block (block
, &se
.pre
);
2143 OMP_CLAUSE_SIZE (node
) = gfc_full_array_size (block
, se
.expr
,
2144 GFC_TYPE_ARRAY_RANK (type
));
2145 elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2146 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2147 OMP_CLAUSE_SIZE (node
) = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2148 OMP_CLAUSE_SIZE (node
), elemsz
);
2150 gcc_assert (se
.post
.head
== NULL_TREE
);
2151 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
2152 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2153 ptr
= fold_convert (ptrdiff_type_node
, ptr
);
2155 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2156 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
)))
2157 && ptr_kind
== GOMP_MAP_POINTER
)
2159 node4
= build_omp_clause (input_location
,
2161 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2162 OMP_CLAUSE_DECL (node4
) = decl
;
2163 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2164 decl
= build_fold_indirect_ref (decl
);
2166 else if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
2167 && n
->expr
->ts
.type
== BT_CHARACTER
2168 && n
->expr
->ts
.deferred
)
2170 gomp_map_kind map_kind
;
2171 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
2172 map_kind
= GOMP_MAP_TO
;
2173 else if (OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_RELEASE
2174 || OMP_CLAUSE_MAP_KIND (node
) == GOMP_MAP_DELETE
)
2175 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
2177 map_kind
= GOMP_MAP_ALLOC
;
2178 gcc_assert (se
.string_length
);
2179 node4
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2180 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
2181 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
2182 OMP_CLAUSE_SIZE (node4
) = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
2184 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2187 tree type
= TREE_TYPE (decl
);
2188 ptr2
= gfc_conv_descriptor_data_get (decl
);
2189 desc_node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2190 OMP_CLAUSE_DECL (desc_node
) = decl
;
2191 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
2192 if (ptr_kind
== GOMP_MAP_ALWAYS_POINTER
)
2194 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO
);
2196 node
= desc_node
; /* Needs to come first. */
2200 OMP_CLAUSE_SET_MAP_KIND (desc_node
, GOMP_MAP_TO_PSET
);
2203 node3
= build_omp_clause (input_location
,
2205 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2206 OMP_CLAUSE_DECL (node3
)
2207 = gfc_conv_descriptor_data_get (decl
);
2208 /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
2209 cast prevents gimplify.c from recognising it as being part of the
2210 struct – and adding an 'alloc: for the 'desc.data' pointer, which
2211 would break as the 'desc' (the descriptor) is also mapped
2212 (see node4 above). */
2213 if (ptr_kind
== GOMP_MAP_ATTACH_DETACH
)
2214 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
2218 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
)
2221 ptr2
= build_fold_addr_expr (decl
);
2222 offset
= fold_build2 (MINUS_EXPR
, ptrdiff_type_node
, ptr
,
2223 fold_convert (ptrdiff_type_node
, ptr2
));
2224 offset
= build2 (TRUNC_DIV_EXPR
, ptrdiff_type_node
,
2225 offset
, fold_convert (ptrdiff_type_node
, elemsz
));
2226 offset
= build4_loc (input_location
, ARRAY_REF
,
2227 TREE_TYPE (TREE_TYPE (decl
)),
2228 decl
, offset
, NULL_TREE
, NULL_TREE
);
2229 OMP_CLAUSE_DECL (node
) = offset
;
2233 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl
)));
2236 node3
= build_omp_clause (input_location
,
2238 OMP_CLAUSE_SET_MAP_KIND (node3
, ptr_kind
);
2239 OMP_CLAUSE_DECL (node3
) = decl
;
2241 ptr2
= fold_convert (ptrdiff_type_node
, ptr2
);
2242 OMP_CLAUSE_SIZE (node3
) = fold_build2 (MINUS_EXPR
, ptrdiff_type_node
,
2247 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
2248 locus where
, bool declare_simd
= false,
2249 bool openacc
= false)
2251 tree omp_clauses
= NULL_TREE
, chunk_size
, c
;
2253 enum omp_clause_code clause_code
;
2256 if (clauses
== NULL
)
2259 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
2261 gfc_omp_namelist
*n
= clauses
->lists
[list
];
2267 case OMP_LIST_REDUCTION
:
2268 /* An OpenACC async clause indicates the need to set reduction
2269 arguments addressable, to allow asynchronous copy-out. */
2270 omp_clauses
= gfc_trans_omp_reduction_list (n
, omp_clauses
, where
,
2273 case OMP_LIST_PRIVATE
:
2274 clause_code
= OMP_CLAUSE_PRIVATE
;
2276 case OMP_LIST_SHARED
:
2277 clause_code
= OMP_CLAUSE_SHARED
;
2279 case OMP_LIST_FIRSTPRIVATE
:
2280 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
2282 case OMP_LIST_LASTPRIVATE
:
2283 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
2285 case OMP_LIST_COPYIN
:
2286 clause_code
= OMP_CLAUSE_COPYIN
;
2288 case OMP_LIST_COPYPRIVATE
:
2289 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
2291 case OMP_LIST_UNIFORM
:
2292 clause_code
= OMP_CLAUSE_UNIFORM
;
2294 case OMP_LIST_USE_DEVICE
:
2295 case OMP_LIST_USE_DEVICE_PTR
:
2296 clause_code
= OMP_CLAUSE_USE_DEVICE_PTR
;
2298 case OMP_LIST_USE_DEVICE_ADDR
:
2299 clause_code
= OMP_CLAUSE_USE_DEVICE_ADDR
;
2301 case OMP_LIST_IS_DEVICE_PTR
:
2302 clause_code
= OMP_CLAUSE_IS_DEVICE_PTR
;
2304 case OMP_LIST_NONTEMPORAL
:
2305 clause_code
= OMP_CLAUSE_NONTEMPORAL
;
2310 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
,
2313 case OMP_LIST_ALIGNED
:
2314 for (; n
!= NULL
; n
= n
->next
)
2315 if (n
->sym
->attr
.referenced
|| declare_simd
)
2317 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2318 if (t
!= error_mark_node
)
2320 tree node
= build_omp_clause (input_location
,
2321 OMP_CLAUSE_ALIGNED
);
2322 OMP_CLAUSE_DECL (node
) = t
;
2328 alignment_var
= gfc_conv_constant_to_tree (n
->expr
);
2331 gfc_init_se (&se
, NULL
);
2332 gfc_conv_expr (&se
, n
->expr
);
2333 gfc_add_block_to_block (block
, &se
.pre
);
2334 alignment_var
= gfc_evaluate_now (se
.expr
, block
);
2335 gfc_add_block_to_block (block
, &se
.post
);
2337 OMP_CLAUSE_ALIGNED_ALIGNMENT (node
) = alignment_var
;
2339 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2343 case OMP_LIST_LINEAR
:
2345 gfc_expr
*last_step_expr
= NULL
;
2346 tree last_step
= NULL_TREE
;
2347 bool last_step_parm
= false;
2349 for (; n
!= NULL
; n
= n
->next
)
2353 last_step_expr
= n
->expr
;
2354 last_step
= NULL_TREE
;
2355 last_step_parm
= false;
2357 if (n
->sym
->attr
.referenced
|| declare_simd
)
2359 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
2360 if (t
!= error_mark_node
)
2362 tree node
= build_omp_clause (input_location
,
2364 OMP_CLAUSE_DECL (node
) = t
;
2365 omp_clause_linear_kind kind
;
2366 switch (n
->u
.linear_op
)
2368 case OMP_LINEAR_DEFAULT
:
2369 kind
= OMP_CLAUSE_LINEAR_DEFAULT
;
2371 case OMP_LINEAR_REF
:
2372 kind
= OMP_CLAUSE_LINEAR_REF
;
2374 case OMP_LINEAR_VAL
:
2375 kind
= OMP_CLAUSE_LINEAR_VAL
;
2377 case OMP_LINEAR_UVAL
:
2378 kind
= OMP_CLAUSE_LINEAR_UVAL
;
2383 OMP_CLAUSE_LINEAR_KIND (node
) = kind
;
2384 if (last_step_expr
&& last_step
== NULL_TREE
)
2388 gfc_init_se (&se
, NULL
);
2389 gfc_conv_expr (&se
, last_step_expr
);
2390 gfc_add_block_to_block (block
, &se
.pre
);
2391 last_step
= gfc_evaluate_now (se
.expr
, block
);
2392 gfc_add_block_to_block (block
, &se
.post
);
2394 else if (last_step_expr
->expr_type
== EXPR_VARIABLE
)
2396 gfc_symbol
*s
= last_step_expr
->symtree
->n
.sym
;
2397 last_step
= gfc_trans_omp_variable (s
, true);
2398 last_step_parm
= true;
2402 = gfc_conv_constant_to_tree (last_step_expr
);
2406 OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node
) = 1;
2407 OMP_CLAUSE_LINEAR_STEP (node
) = last_step
;
2411 if (kind
== OMP_CLAUSE_LINEAR_REF
)
2414 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
)
2416 type
= gfc_get_function_type (n
->sym
);
2417 type
= build_pointer_type (type
);
2420 type
= gfc_sym_type (n
->sym
);
2421 if (POINTER_TYPE_P (type
))
2422 type
= TREE_TYPE (type
);
2423 /* Otherwise to be determined what exactly
2425 tree t
= fold_convert (sizetype
, last_step
);
2426 t
= size_binop (MULT_EXPR
, t
,
2427 TYPE_SIZE_UNIT (type
));
2428 OMP_CLAUSE_LINEAR_STEP (node
) = t
;
2433 = gfc_typenode_for_spec (&n
->sym
->ts
);
2434 OMP_CLAUSE_LINEAR_STEP (node
)
2435 = fold_convert (type
, last_step
);
2438 if (n
->sym
->attr
.dimension
|| n
->sym
->attr
.allocatable
)
2439 OMP_CLAUSE_LINEAR_ARRAY (node
) = 1;
2440 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2446 case OMP_LIST_DEPEND
:
2447 for (; n
!= NULL
; n
= n
->next
)
2449 if (n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
)
2451 tree vec
= NULL_TREE
;
2455 tree addend
= integer_zero_node
, t
;
2459 addend
= gfc_conv_constant_to_tree (n
->expr
);
2460 if (TREE_CODE (addend
) == INTEGER_CST
2461 && tree_int_cst_sgn (addend
) == -1)
2464 addend
= const_unop (NEGATE_EXPR
,
2465 TREE_TYPE (addend
), addend
);
2468 t
= gfc_trans_omp_variable (n
->sym
, false);
2469 if (t
!= error_mark_node
)
2471 if (i
< vec_safe_length (doacross_steps
)
2472 && !integer_zerop (addend
)
2473 && (*doacross_steps
)[i
])
2475 tree step
= (*doacross_steps
)[i
];
2476 addend
= fold_convert (TREE_TYPE (step
), addend
);
2477 addend
= build2 (TRUNC_DIV_EXPR
,
2478 TREE_TYPE (step
), addend
, step
);
2480 vec
= tree_cons (addend
, t
, vec
);
2482 OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec
) = 1;
2485 || n
->next
->u
.depend_op
!= OMP_DEPEND_SINK
)
2489 if (vec
== NULL_TREE
)
2492 tree node
= build_omp_clause (input_location
,
2494 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_SINK
;
2495 OMP_CLAUSE_DECL (node
) = nreverse (vec
);
2496 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2500 if (!n
->sym
->attr
.referenced
)
2503 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_DEPEND
);
2504 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2506 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2507 if (gfc_omp_privatize_by_reference (decl
))
2508 decl
= build_fold_indirect_ref (decl
);
2509 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2511 decl
= gfc_conv_descriptor_data_get (decl
);
2512 decl
= fold_convert (build_pointer_type (char_type_node
),
2514 decl
= build_fold_indirect_ref (decl
);
2516 else if (DECL_P (decl
))
2517 TREE_ADDRESSABLE (decl
) = 1;
2518 OMP_CLAUSE_DECL (node
) = decl
;
2523 gfc_init_se (&se
, NULL
);
2524 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2526 gfc_conv_expr_reference (&se
, n
->expr
);
2531 gfc_conv_expr_descriptor (&se
, n
->expr
);
2532 ptr
= gfc_conv_array_data (se
.expr
);
2534 gfc_add_block_to_block (block
, &se
.pre
);
2535 gfc_add_block_to_block (block
, &se
.post
);
2536 ptr
= fold_convert (build_pointer_type (char_type_node
),
2538 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2540 switch (n
->u
.depend_op
)
2543 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_IN
;
2545 case OMP_DEPEND_OUT
:
2546 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_OUT
;
2548 case OMP_DEPEND_INOUT
:
2549 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_INOUT
;
2554 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2558 for (; n
!= NULL
; n
= n
->next
)
2560 if (!n
->sym
->attr
.referenced
)
2563 bool always_modifier
= false;
2564 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2565 tree node2
= NULL_TREE
;
2566 tree node3
= NULL_TREE
;
2567 tree node4
= NULL_TREE
;
2569 /* OpenMP: automatically map pointer targets with the pointer;
2570 hence, always update the descriptor/pointer itself. */
2572 && ((n
->expr
== NULL
&& n
->sym
->attr
.pointer
)
2573 || (n
->expr
&& gfc_expr_attr (n
->expr
).pointer
)))
2574 always_modifier
= true;
2576 switch (n
->u
.map_op
)
2579 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALLOC
);
2581 case OMP_MAP_IF_PRESENT
:
2582 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_IF_PRESENT
);
2584 case OMP_MAP_ATTACH
:
2585 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ATTACH
);
2588 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TO
);
2591 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FROM
);
2593 case OMP_MAP_TOFROM
:
2594 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TOFROM
);
2596 case OMP_MAP_ALWAYS_TO
:
2597 always_modifier
= true;
2598 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TO
);
2600 case OMP_MAP_ALWAYS_FROM
:
2601 always_modifier
= true;
2602 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_FROM
);
2604 case OMP_MAP_ALWAYS_TOFROM
:
2605 always_modifier
= true;
2606 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALWAYS_TOFROM
);
2608 case OMP_MAP_RELEASE
:
2609 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_RELEASE
);
2611 case OMP_MAP_DELETE
:
2612 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DELETE
);
2614 case OMP_MAP_DETACH
:
2615 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DETACH
);
2617 case OMP_MAP_FORCE_ALLOC
:
2618 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_ALLOC
);
2620 case OMP_MAP_FORCE_TO
:
2621 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TO
);
2623 case OMP_MAP_FORCE_FROM
:
2624 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_FROM
);
2626 case OMP_MAP_FORCE_TOFROM
:
2627 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TOFROM
);
2629 case OMP_MAP_FORCE_PRESENT
:
2630 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_PRESENT
);
2632 case OMP_MAP_FORCE_DEVICEPTR
:
2633 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_DEVICEPTR
);
2639 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
2641 TREE_ADDRESSABLE (decl
) = 1;
2643 || (n
->expr
->ref
->type
== REF_ARRAY
2644 && n
->expr
->ref
->u
.ar
.type
== AR_FULL
))
2646 tree present
= gfc_omp_check_optional_argument (decl
, true);
2647 if (openacc
&& n
->sym
->ts
.type
== BT_CLASS
)
2649 tree type
= TREE_TYPE (decl
);
2650 if (n
->sym
->attr
.optional
)
2651 sorry ("optional class parameter");
2652 if (POINTER_TYPE_P (type
))
2654 node4
= build_omp_clause (input_location
,
2656 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2657 OMP_CLAUSE_DECL (node4
) = decl
;
2658 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2659 decl
= build_fold_indirect_ref (decl
);
2661 tree ptr
= gfc_class_data_get (decl
);
2662 ptr
= build_fold_indirect_ref (ptr
);
2663 OMP_CLAUSE_DECL (node
) = ptr
;
2664 OMP_CLAUSE_SIZE (node
) = gfc_class_vtab_size_get (decl
);
2665 node2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2666 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2667 OMP_CLAUSE_DECL (node2
) = decl
;
2668 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2669 node3
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
2670 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH_DETACH
);
2671 OMP_CLAUSE_DECL (node3
) = gfc_class_data_get (decl
);
2672 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2673 goto finalize_map_clause
;
2675 else if (POINTER_TYPE_P (TREE_TYPE (decl
))
2676 && (gfc_omp_privatize_by_reference (decl
)
2677 || GFC_DECL_GET_SCALAR_POINTER (decl
)
2678 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
2679 || GFC_DECL_CRAY_POINTEE (decl
)
2680 || GFC_DESCRIPTOR_TYPE_P
2681 (TREE_TYPE (TREE_TYPE (decl
)))
2682 || n
->sym
->ts
.type
== BT_DERIVED
))
2684 tree orig_decl
= decl
;
2686 /* For nonallocatable, nonpointer arrays, a temporary
2687 variable is generated, but this one is only defined if
2688 the variable is present; hence, we now set it to NULL
2689 to avoid accessing undefined variables. We cannot use
2690 a temporary variable here as otherwise the replacement
2691 of the variables in omp-low.c will not work. */
2692 if (present
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)))
2694 tree tmp
= fold_build2_loc (input_location
,
2696 void_type_node
, decl
,
2698 tree cond
= fold_build1_loc (input_location
,
2702 gfc_add_expr_to_block (block
,
2703 build3_loc (input_location
,
2709 node4
= build_omp_clause (input_location
,
2711 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2712 OMP_CLAUSE_DECL (node4
) = decl
;
2713 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2714 decl
= build_fold_indirect_ref (decl
);
2715 if ((TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
2716 || gfc_omp_is_optional_argument (orig_decl
))
2717 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
2718 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
2720 node3
= build_omp_clause (input_location
,
2722 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2723 OMP_CLAUSE_DECL (node3
) = decl
;
2724 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2725 decl
= build_fold_indirect_ref (decl
);
2728 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2730 tree type
= TREE_TYPE (decl
);
2731 tree ptr
= gfc_conv_descriptor_data_get (decl
);
2733 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
2735 ptr
= fold_convert (build_pointer_type (char_type_node
),
2737 ptr
= build_fold_indirect_ref (ptr
);
2738 OMP_CLAUSE_DECL (node
) = ptr
;
2739 node2
= build_omp_clause (input_location
,
2741 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2742 OMP_CLAUSE_DECL (node2
) = decl
;
2743 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2744 node3
= build_omp_clause (input_location
,
2748 ptr
= gfc_conv_descriptor_data_get (decl
);
2749 ptr
= gfc_build_addr_expr (NULL
, ptr
);
2750 ptr
= gfc_build_cond_assign_expr (block
, present
, ptr
,
2752 ptr
= build_fold_indirect_ref (ptr
);
2753 OMP_CLAUSE_DECL (node3
) = ptr
;
2756 OMP_CLAUSE_DECL (node3
)
2757 = gfc_conv_descriptor_data_get (decl
);
2758 OMP_CLAUSE_SIZE (node3
) = size_int (0);
2759 if (n
->u
.map_op
== OMP_MAP_ATTACH
)
2761 /* Standalone attach clauses used with arrays with
2762 descriptors must copy the descriptor to the target,
2763 else they won't have anything to perform the
2764 attachment onto (see OpenACC 2.6, "2.6.3. Data
2765 Structures with Pointers"). */
2766 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_ATTACH
);
2767 /* We don't want to map PTR at all in this case, so
2768 delete its node and shuffle the others down. */
2772 goto finalize_map_clause
;
2774 else if (n
->u
.map_op
== OMP_MAP_DETACH
)
2776 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_DETACH
);
2777 /* Similarly to above, we don't want to unmap PTR
2782 goto finalize_map_clause
;
2785 OMP_CLAUSE_SET_MAP_KIND (node3
,
2787 ? GOMP_MAP_ALWAYS_POINTER
2788 : GOMP_MAP_POINTER
);
2790 /* We have to check for n->sym->attr.dimension because
2791 of scalar coarrays. */
2792 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.dimension
)
2794 stmtblock_t cond_block
;
2796 = gfc_create_var (gfc_array_index_type
, NULL
);
2797 tree tem
, then_b
, else_b
, zero
, cond
;
2799 gfc_init_block (&cond_block
);
2801 = gfc_full_array_size (&cond_block
, decl
,
2802 GFC_TYPE_ARRAY_RANK (type
));
2803 gfc_add_modify (&cond_block
, size
, tem
);
2804 then_b
= gfc_finish_block (&cond_block
);
2805 gfc_init_block (&cond_block
);
2806 zero
= build_int_cst (gfc_array_index_type
, 0);
2807 gfc_add_modify (&cond_block
, size
, zero
);
2808 else_b
= gfc_finish_block (&cond_block
);
2809 tem
= gfc_conv_descriptor_data_get (decl
);
2810 tem
= fold_convert (pvoid_type_node
, tem
);
2811 cond
= fold_build2_loc (input_location
, NE_EXPR
,
2813 tem
, null_pointer_node
);
2815 cond
= fold_build2_loc (input_location
,
2819 gfc_add_expr_to_block (block
,
2820 build3_loc (input_location
,
2825 OMP_CLAUSE_SIZE (node
) = size
;
2827 else if (n
->sym
->attr
.dimension
)
2829 stmtblock_t cond_block
;
2830 gfc_init_block (&cond_block
);
2831 tree size
= gfc_full_array_size (&cond_block
, decl
,
2832 GFC_TYPE_ARRAY_RANK (type
));
2835 tree var
= gfc_create_var (gfc_array_index_type
,
2837 gfc_add_modify (&cond_block
, var
, size
);
2838 tree cond_body
= gfc_finish_block (&cond_block
);
2839 tree cond
= build3_loc (input_location
, COND_EXPR
,
2840 void_type_node
, present
,
2841 cond_body
, NULL_TREE
);
2842 gfc_add_expr_to_block (block
, cond
);
2843 OMP_CLAUSE_SIZE (node
) = var
;
2847 gfc_add_block_to_block (block
, &cond_block
);
2848 OMP_CLAUSE_SIZE (node
) = size
;
2851 if (n
->sym
->attr
.dimension
)
2854 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2855 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2856 OMP_CLAUSE_SIZE (node
)
2857 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2858 OMP_CLAUSE_SIZE (node
), elemsz
);
2862 && TREE_CODE (decl
) == INDIRECT_REF
2863 && (TREE_CODE (TREE_OPERAND (decl
, 0))
2866 /* A single indirectref is handled by the middle end. */
2867 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl
)));
2868 decl
= TREE_OPERAND (decl
, 0);
2869 decl
= gfc_build_cond_assign_expr (block
, present
, decl
,
2871 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (decl
);
2874 OMP_CLAUSE_DECL (node
) = decl
;
2877 && n
->expr
->expr_type
== EXPR_VARIABLE
2878 && n
->expr
->ref
->type
== REF_COMPONENT
)
2882 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
2883 if (ref
->type
== REF_COMPONENT
)
2886 symbol_attribute sym_attr
;
2888 if (lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2889 sym_attr
= CLASS_DATA (lastcomp
->u
.c
.component
)->attr
;
2891 sym_attr
= lastcomp
->u
.c
.component
->attr
;
2893 gfc_init_se (&se
, NULL
);
2895 if (!sym_attr
.dimension
2896 && lastcomp
->u
.c
.component
->ts
.type
!= BT_CLASS
2897 && lastcomp
->u
.c
.component
->ts
.type
!= BT_DERIVED
)
2899 /* Last component is a scalar. */
2900 gfc_conv_expr (&se
, n
->expr
);
2901 gfc_add_block_to_block (block
, &se
.pre
);
2902 /* For BT_CHARACTER a pointer is returned. */
2903 OMP_CLAUSE_DECL (node
)
2904 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
2905 ? build_fold_indirect_ref (se
.expr
) : se
.expr
;
2906 gfc_add_block_to_block (block
, &se
.post
);
2907 if (sym_attr
.pointer
|| sym_attr
.allocatable
)
2909 node2
= build_omp_clause (input_location
,
2911 OMP_CLAUSE_SET_MAP_KIND (node2
,
2913 ? GOMP_MAP_ATTACH_DETACH
2914 : GOMP_MAP_ALWAYS_POINTER
);
2915 OMP_CLAUSE_DECL (node2
)
2916 = POINTER_TYPE_P (TREE_TYPE (se
.expr
))
2917 ? se
.expr
: gfc_build_addr_expr (NULL
, se
.expr
);
2918 OMP_CLAUSE_SIZE (node2
) = size_int (0);
2920 && n
->expr
->ts
.type
== BT_CHARACTER
2921 && n
->expr
->ts
.deferred
)
2923 gcc_assert (se
.string_length
);
2924 tree tmp
= gfc_get_char_type (n
->expr
->ts
.kind
);
2925 OMP_CLAUSE_SIZE (node
)
2926 = fold_build2 (MULT_EXPR
, size_type_node
,
2927 fold_convert (size_type_node
,
2929 TYPE_SIZE_UNIT (tmp
));
2930 node3
= build_omp_clause (input_location
,
2932 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_TO
);
2933 OMP_CLAUSE_DECL (node3
) = se
.string_length
;
2934 OMP_CLAUSE_SIZE (node3
)
2935 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
2938 goto finalize_map_clause
;
2941 se
.expr
= gfc_maybe_dereference_var (n
->sym
, decl
);
2943 for (gfc_ref
*ref
= n
->expr
->ref
;
2944 ref
&& ref
!= lastcomp
->next
;
2947 if (ref
->type
== REF_COMPONENT
)
2949 if (ref
->u
.c
.sym
->attr
.extension
)
2950 conv_parent_component_references (&se
, ref
);
2952 gfc_conv_component_ref (&se
, ref
);
2955 sorry ("unhandled derived-type component");
2958 tree inner
= se
.expr
;
2960 /* Last component is a derived type or class pointer. */
2961 if (lastcomp
->u
.c
.component
->ts
.type
== BT_DERIVED
2962 || lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2964 if (sym_attr
.pointer
|| (openacc
&& sym_attr
.allocatable
))
2968 if (lastcomp
->u
.c
.component
->ts
.type
== BT_CLASS
)
2970 data
= gfc_class_data_get (inner
);
2971 size
= gfc_class_vtab_size_get (inner
);
2973 else /* BT_DERIVED. */
2976 size
= TYPE_SIZE_UNIT (TREE_TYPE (inner
));
2979 OMP_CLAUSE_DECL (node
)
2980 = build_fold_indirect_ref (data
);
2981 OMP_CLAUSE_SIZE (node
) = size
;
2982 node2
= build_omp_clause (input_location
,
2984 OMP_CLAUSE_SET_MAP_KIND (node2
,
2986 ? GOMP_MAP_ATTACH_DETACH
2987 : GOMP_MAP_ALWAYS_POINTER
);
2988 OMP_CLAUSE_DECL (node2
) = data
;
2989 OMP_CLAUSE_SIZE (node2
) = size_int (0);
2993 OMP_CLAUSE_DECL (node
) = inner
;
2994 OMP_CLAUSE_SIZE (node
)
2995 = TYPE_SIZE_UNIT (TREE_TYPE (inner
));
2998 else if (lastcomp
->next
2999 && lastcomp
->next
->type
== REF_ARRAY
3000 && lastcomp
->next
->u
.ar
.type
== AR_FULL
)
3002 /* Just pass the (auto-dereferenced) decl through for
3003 bare attach and detach clauses. */
3004 if (n
->u
.map_op
== OMP_MAP_ATTACH
3005 || n
->u
.map_op
== OMP_MAP_DETACH
)
3007 OMP_CLAUSE_DECL (node
) = inner
;
3008 OMP_CLAUSE_SIZE (node
) = size_zero_node
;
3009 goto finalize_map_clause
;
3012 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner
)))
3014 gomp_map_kind map_kind
;
3016 tree type
= TREE_TYPE (inner
);
3017 tree ptr
= gfc_conv_descriptor_data_get (inner
);
3018 ptr
= build_fold_indirect_ref (ptr
);
3019 OMP_CLAUSE_DECL (node
) = ptr
;
3020 int rank
= GFC_TYPE_ARRAY_RANK (type
);
3021 OMP_CLAUSE_SIZE (node
)
3022 = gfc_full_array_size (block
, inner
, rank
);
3024 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3025 if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node
)))
3026 map_kind
= GOMP_MAP_TO
;
3027 else if (n
->u
.map_op
== OMP_MAP_RELEASE
3028 || n
->u
.map_op
== OMP_MAP_DELETE
)
3029 map_kind
= OMP_CLAUSE_MAP_KIND (node
);
3031 map_kind
= GOMP_MAP_ALLOC
;
3033 && n
->expr
->ts
.type
== BT_CHARACTER
3034 && n
->expr
->ts
.deferred
)
3036 gcc_assert (se
.string_length
);
3037 tree len
= fold_convert (size_type_node
,
3039 elemsz
= gfc_get_char_type (n
->expr
->ts
.kind
);
3040 elemsz
= TYPE_SIZE_UNIT (elemsz
);
3041 elemsz
= fold_build2 (MULT_EXPR
, size_type_node
,
3043 node4
= build_omp_clause (input_location
,
3045 OMP_CLAUSE_SET_MAP_KIND (node4
, map_kind
);
3046 OMP_CLAUSE_DECL (node4
) = se
.string_length
;
3047 OMP_CLAUSE_SIZE (node4
)
3048 = TYPE_SIZE_UNIT (gfc_charlen_type_node
);
3050 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3051 OMP_CLAUSE_SIZE (node
)
3052 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3053 OMP_CLAUSE_SIZE (node
), elemsz
);
3054 desc_node
= build_omp_clause (input_location
,
3057 OMP_CLAUSE_SET_MAP_KIND (desc_node
,
3060 OMP_CLAUSE_SET_MAP_KIND (desc_node
, map_kind
);
3061 OMP_CLAUSE_DECL (desc_node
) = inner
;
3062 OMP_CLAUSE_SIZE (desc_node
) = TYPE_SIZE_UNIT (type
);
3068 node
= desc_node
; /* Put first. */
3070 node3
= build_omp_clause (input_location
,
3072 OMP_CLAUSE_SET_MAP_KIND (node3
,
3074 ? GOMP_MAP_ATTACH_DETACH
3075 : GOMP_MAP_ALWAYS_POINTER
);
3076 OMP_CLAUSE_DECL (node3
)
3077 = gfc_conv_descriptor_data_get (inner
);
3078 /* Similar to gfc_trans_omp_array_section (details
3079 there), we add/keep the cast for OpenMP to prevent
3080 that an 'alloc:' gets added for node3 ('desc.data')
3081 as that is part of the whole descriptor (node3).
3082 TODO: Remove once the ME handles this properly. */
3084 OMP_CLAUSE_DECL (node3
)
3085 = fold_convert (TREE_TYPE (TREE_OPERAND(ptr
, 0)),
3086 OMP_CLAUSE_DECL (node3
));
3088 STRIP_NOPS (OMP_CLAUSE_DECL (node3
));
3089 OMP_CLAUSE_SIZE (node3
) = size_int (0);
3092 OMP_CLAUSE_DECL (node
) = inner
;
3094 else /* An array element or section. */
3098 && lastcomp
->next
->type
== REF_ARRAY
3099 && lastcomp
->next
->u
.ar
.type
== AR_ELEMENT
);
3101 gomp_map_kind kind
= (openacc
? GOMP_MAP_ATTACH_DETACH
3102 : GOMP_MAP_ALWAYS_POINTER
);
3103 gfc_trans_omp_array_section (block
, n
, inner
, element
,
3104 kind
, node
, node2
, node3
,
3108 else /* An array element or array section. */
3110 bool element
= n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
;
3111 gfc_trans_omp_array_section (block
, n
, decl
, element
,
3112 GOMP_MAP_POINTER
, node
, node2
,
3116 finalize_map_clause
:
3118 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3120 omp_clauses
= gfc_trans_add_clause (node2
, omp_clauses
);
3122 omp_clauses
= gfc_trans_add_clause (node3
, omp_clauses
);
3124 omp_clauses
= gfc_trans_add_clause (node4
, omp_clauses
);
3129 case OMP_LIST_CACHE
:
3130 for (; n
!= NULL
; n
= n
->next
)
3132 if (!n
->sym
->attr
.referenced
)
3138 clause_code
= OMP_CLAUSE_TO
;
3141 clause_code
= OMP_CLAUSE_FROM
;
3143 case OMP_LIST_CACHE
:
3144 clause_code
= OMP_CLAUSE__CACHE_
;
3149 tree node
= build_omp_clause (input_location
, clause_code
);
3150 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
3152 tree decl
= gfc_trans_omp_variable (n
->sym
, false);
3153 if (gfc_omp_privatize_by_reference (decl
))
3155 if (gfc_omp_is_allocatable_or_ptr (decl
))
3156 decl
= build_fold_indirect_ref (decl
);
3157 decl
= build_fold_indirect_ref (decl
);
3159 else if (DECL_P (decl
))
3160 TREE_ADDRESSABLE (decl
) = 1;
3161 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
3163 tree type
= TREE_TYPE (decl
);
3164 tree ptr
= gfc_conv_descriptor_data_get (decl
);
3165 ptr
= fold_convert (build_pointer_type (char_type_node
),
3167 ptr
= build_fold_indirect_ref (ptr
);
3168 OMP_CLAUSE_DECL (node
) = ptr
;
3169 OMP_CLAUSE_SIZE (node
)
3170 = gfc_full_array_size (block
, decl
,
3171 GFC_TYPE_ARRAY_RANK (type
));
3173 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3174 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3175 OMP_CLAUSE_SIZE (node
)
3176 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3177 OMP_CLAUSE_SIZE (node
), elemsz
);
3181 OMP_CLAUSE_DECL (node
) = decl
;
3182 if (gfc_omp_is_allocatable_or_ptr (decl
))
3183 OMP_CLAUSE_SIZE (node
)
3184 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl
)));
3190 gfc_init_se (&se
, NULL
);
3191 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
3193 gfc_conv_expr_reference (&se
, n
->expr
);
3195 gfc_add_block_to_block (block
, &se
.pre
);
3196 OMP_CLAUSE_SIZE (node
)
3197 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
3201 gfc_conv_expr_descriptor (&se
, n
->expr
);
3202 ptr
= gfc_conv_array_data (se
.expr
);
3203 tree type
= TREE_TYPE (se
.expr
);
3204 gfc_add_block_to_block (block
, &se
.pre
);
3205 OMP_CLAUSE_SIZE (node
)
3206 = gfc_full_array_size (block
, se
.expr
,
3207 GFC_TYPE_ARRAY_RANK (type
));
3209 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3210 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
3211 OMP_CLAUSE_SIZE (node
)
3212 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3213 OMP_CLAUSE_SIZE (node
), elemsz
);
3215 gfc_add_block_to_block (block
, &se
.post
);
3216 ptr
= fold_convert (build_pointer_type (char_type_node
),
3218 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
3220 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
3228 if (clauses
->if_expr
)
3232 gfc_init_se (&se
, NULL
);
3233 gfc_conv_expr (&se
, clauses
->if_expr
);
3234 gfc_add_block_to_block (block
, &se
.pre
);
3235 if_var
= gfc_evaluate_now (se
.expr
, block
);
3236 gfc_add_block_to_block (block
, &se
.post
);
3238 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3239 OMP_CLAUSE_IF_MODIFIER (c
) = ERROR_MARK
;
3240 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3241 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3243 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
3244 if (clauses
->if_exprs
[ifc
])
3248 gfc_init_se (&se
, NULL
);
3249 gfc_conv_expr (&se
, clauses
->if_exprs
[ifc
]);
3250 gfc_add_block_to_block (block
, &se
.pre
);
3251 if_var
= gfc_evaluate_now (se
.expr
, block
);
3252 gfc_add_block_to_block (block
, &se
.post
);
3254 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF
);
3258 OMP_CLAUSE_IF_MODIFIER (c
) = VOID_CST
;
3260 case OMP_IF_PARALLEL
:
3261 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_PARALLEL
;
3264 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_SIMD
;
3267 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASK
;
3269 case OMP_IF_TASKLOOP
:
3270 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TASKLOOP
;
3273 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET
;
3275 case OMP_IF_TARGET_DATA
:
3276 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_DATA
;
3278 case OMP_IF_TARGET_UPDATE
:
3279 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_UPDATE
;
3281 case OMP_IF_TARGET_ENTER_DATA
:
3282 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_ENTER_DATA
;
3284 case OMP_IF_TARGET_EXIT_DATA
:
3285 OMP_CLAUSE_IF_MODIFIER (c
) = OMP_TARGET_EXIT_DATA
;
3290 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
3291 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3294 if (clauses
->final_expr
)
3298 gfc_init_se (&se
, NULL
);
3299 gfc_conv_expr (&se
, clauses
->final_expr
);
3300 gfc_add_block_to_block (block
, &se
.pre
);
3301 final_var
= gfc_evaluate_now (se
.expr
, block
);
3302 gfc_add_block_to_block (block
, &se
.post
);
3304 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINAL
);
3305 OMP_CLAUSE_FINAL_EXPR (c
) = final_var
;
3306 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3309 if (clauses
->num_threads
)
3313 gfc_init_se (&se
, NULL
);
3314 gfc_conv_expr (&se
, clauses
->num_threads
);
3315 gfc_add_block_to_block (block
, &se
.pre
);
3316 num_threads
= gfc_evaluate_now (se
.expr
, block
);
3317 gfc_add_block_to_block (block
, &se
.post
);
3319 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_THREADS
);
3320 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
3321 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3324 chunk_size
= NULL_TREE
;
3325 if (clauses
->chunk_size
)
3327 gfc_init_se (&se
, NULL
);
3328 gfc_conv_expr (&se
, clauses
->chunk_size
);
3329 gfc_add_block_to_block (block
, &se
.pre
);
3330 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3331 gfc_add_block_to_block (block
, &se
.post
);
3334 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
3336 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SCHEDULE
);
3337 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3338 switch (clauses
->sched_kind
)
3340 case OMP_SCHED_STATIC
:
3341 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
3343 case OMP_SCHED_DYNAMIC
:
3344 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
3346 case OMP_SCHED_GUIDED
:
3347 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
3349 case OMP_SCHED_RUNTIME
:
3350 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
3352 case OMP_SCHED_AUTO
:
3353 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
3358 if (clauses
->sched_monotonic
)
3359 OMP_CLAUSE_SCHEDULE_KIND (c
)
3360 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3361 | OMP_CLAUSE_SCHEDULE_MONOTONIC
);
3362 else if (clauses
->sched_nonmonotonic
)
3363 OMP_CLAUSE_SCHEDULE_KIND (c
)
3364 = (omp_clause_schedule_kind
) (OMP_CLAUSE_SCHEDULE_KIND (c
)
3365 | OMP_CLAUSE_SCHEDULE_NONMONOTONIC
);
3366 if (clauses
->sched_simd
)
3367 OMP_CLAUSE_SCHEDULE_SIMD (c
) = 1;
3368 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3371 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
3373 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULT
);
3374 switch (clauses
->default_sharing
)
3376 case OMP_DEFAULT_NONE
:
3377 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
3379 case OMP_DEFAULT_SHARED
:
3380 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
3382 case OMP_DEFAULT_PRIVATE
:
3383 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
3385 case OMP_DEFAULT_FIRSTPRIVATE
:
3386 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
3388 case OMP_DEFAULT_PRESENT
:
3389 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRESENT
;
3394 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3397 if (clauses
->nowait
)
3399 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOWAIT
);
3400 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3403 if (clauses
->ordered
)
3405 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDERED
);
3406 OMP_CLAUSE_ORDERED_EXPR (c
)
3407 = clauses
->orderedc
? build_int_cst (integer_type_node
,
3408 clauses
->orderedc
) : NULL_TREE
;
3409 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3412 if (clauses
->order_concurrent
)
3414 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ORDER
);
3415 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3418 if (clauses
->untied
)
3420 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_UNTIED
);
3421 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3424 if (clauses
->mergeable
)
3426 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_MERGEABLE
);
3427 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3430 if (clauses
->collapse
)
3432 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_COLLAPSE
);
3433 OMP_CLAUSE_COLLAPSE_EXPR (c
)
3434 = build_int_cst (integer_type_node
, clauses
->collapse
);
3435 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3438 if (clauses
->inbranch
)
3440 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INBRANCH
);
3441 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3444 if (clauses
->notinbranch
)
3446 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOTINBRANCH
);
3447 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3450 switch (clauses
->cancel
)
3452 case OMP_CANCEL_UNKNOWN
:
3454 case OMP_CANCEL_PARALLEL
:
3455 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PARALLEL
);
3456 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3458 case OMP_CANCEL_SECTIONS
:
3459 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SECTIONS
);
3460 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3463 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FOR
);
3464 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3466 case OMP_CANCEL_TASKGROUP
:
3467 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TASKGROUP
);
3468 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3472 if (clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
3474 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PROC_BIND
);
3475 switch (clauses
->proc_bind
)
3477 case OMP_PROC_BIND_MASTER
:
3478 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_MASTER
;
3480 case OMP_PROC_BIND_SPREAD
:
3481 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_SPREAD
;
3483 case OMP_PROC_BIND_CLOSE
:
3484 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_CLOSE
;
3489 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3492 if (clauses
->safelen_expr
)
3496 gfc_init_se (&se
, NULL
);
3497 gfc_conv_expr (&se
, clauses
->safelen_expr
);
3498 gfc_add_block_to_block (block
, &se
.pre
);
3499 safelen_var
= gfc_evaluate_now (se
.expr
, block
);
3500 gfc_add_block_to_block (block
, &se
.post
);
3502 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SAFELEN
);
3503 OMP_CLAUSE_SAFELEN_EXPR (c
) = safelen_var
;
3504 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3507 if (clauses
->simdlen_expr
)
3511 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3512 OMP_CLAUSE_SIMDLEN_EXPR (c
)
3513 = gfc_conv_constant_to_tree (clauses
->simdlen_expr
);
3514 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3520 gfc_init_se (&se
, NULL
);
3521 gfc_conv_expr (&se
, clauses
->simdlen_expr
);
3522 gfc_add_block_to_block (block
, &se
.pre
);
3523 simdlen_var
= gfc_evaluate_now (se
.expr
, block
);
3524 gfc_add_block_to_block (block
, &se
.post
);
3526 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMDLEN
);
3527 OMP_CLAUSE_SIMDLEN_EXPR (c
) = simdlen_var
;
3528 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3532 if (clauses
->num_teams
)
3536 gfc_init_se (&se
, NULL
);
3537 gfc_conv_expr (&se
, clauses
->num_teams
);
3538 gfc_add_block_to_block (block
, &se
.pre
);
3539 num_teams
= gfc_evaluate_now (se
.expr
, block
);
3540 gfc_add_block_to_block (block
, &se
.post
);
3542 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TEAMS
);
3543 OMP_CLAUSE_NUM_TEAMS_EXPR (c
) = num_teams
;
3544 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3547 if (clauses
->device
)
3551 gfc_init_se (&se
, NULL
);
3552 gfc_conv_expr (&se
, clauses
->device
);
3553 gfc_add_block_to_block (block
, &se
.pre
);
3554 device
= gfc_evaluate_now (se
.expr
, block
);
3555 gfc_add_block_to_block (block
, &se
.post
);
3557 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEVICE
);
3558 OMP_CLAUSE_DEVICE_ID (c
) = device
;
3559 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3562 if (clauses
->thread_limit
)
3566 gfc_init_se (&se
, NULL
);
3567 gfc_conv_expr (&se
, clauses
->thread_limit
);
3568 gfc_add_block_to_block (block
, &se
.pre
);
3569 thread_limit
= gfc_evaluate_now (se
.expr
, block
);
3570 gfc_add_block_to_block (block
, &se
.post
);
3572 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREAD_LIMIT
);
3573 OMP_CLAUSE_THREAD_LIMIT_EXPR (c
) = thread_limit
;
3574 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3577 chunk_size
= NULL_TREE
;
3578 if (clauses
->dist_chunk_size
)
3580 gfc_init_se (&se
, NULL
);
3581 gfc_conv_expr (&se
, clauses
->dist_chunk_size
);
3582 gfc_add_block_to_block (block
, &se
.pre
);
3583 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
3584 gfc_add_block_to_block (block
, &se
.post
);
3587 if (clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
3589 c
= build_omp_clause (gfc_get_location (&where
),
3590 OMP_CLAUSE_DIST_SCHEDULE
);
3591 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
3592 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3595 if (clauses
->grainsize
)
3599 gfc_init_se (&se
, NULL
);
3600 gfc_conv_expr (&se
, clauses
->grainsize
);
3601 gfc_add_block_to_block (block
, &se
.pre
);
3602 grainsize
= gfc_evaluate_now (se
.expr
, block
);
3603 gfc_add_block_to_block (block
, &se
.post
);
3605 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GRAINSIZE
);
3606 OMP_CLAUSE_GRAINSIZE_EXPR (c
) = grainsize
;
3607 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3610 if (clauses
->num_tasks
)
3614 gfc_init_se (&se
, NULL
);
3615 gfc_conv_expr (&se
, clauses
->num_tasks
);
3616 gfc_add_block_to_block (block
, &se
.pre
);
3617 num_tasks
= gfc_evaluate_now (se
.expr
, block
);
3618 gfc_add_block_to_block (block
, &se
.post
);
3620 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_TASKS
);
3621 OMP_CLAUSE_NUM_TASKS_EXPR (c
) = num_tasks
;
3622 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3625 if (clauses
->priority
)
3629 gfc_init_se (&se
, NULL
);
3630 gfc_conv_expr (&se
, clauses
->priority
);
3631 gfc_add_block_to_block (block
, &se
.pre
);
3632 priority
= gfc_evaluate_now (se
.expr
, block
);
3633 gfc_add_block_to_block (block
, &se
.post
);
3635 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_PRIORITY
);
3636 OMP_CLAUSE_PRIORITY_EXPR (c
) = priority
;
3637 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3644 gfc_init_se (&se
, NULL
);
3645 gfc_conv_expr (&se
, clauses
->hint
);
3646 gfc_add_block_to_block (block
, &se
.pre
);
3647 hint
= gfc_evaluate_now (se
.expr
, block
);
3648 gfc_add_block_to_block (block
, &se
.post
);
3650 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_HINT
);
3651 OMP_CLAUSE_HINT_EXPR (c
) = hint
;
3652 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3657 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SIMD
);
3658 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3660 if (clauses
->threads
)
3662 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_THREADS
);
3663 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3665 if (clauses
->nogroup
)
3667 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NOGROUP
);
3668 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3670 if (clauses
->defaultmap
)
3672 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEFAULTMAP
);
3673 OMP_CLAUSE_DEFAULTMAP_SET_KIND (c
, OMP_CLAUSE_DEFAULTMAP_TOFROM
,
3674 OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR
);
3675 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3677 if (clauses
->depend_source
)
3679 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_DEPEND
);
3680 OMP_CLAUSE_DEPEND_KIND (c
) = OMP_CLAUSE_DEPEND_SOURCE
;
3681 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3686 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_ASYNC
);
3687 if (clauses
->async_expr
)
3688 OMP_CLAUSE_ASYNC_EXPR (c
)
3689 = gfc_convert_expr_to_tree (block
, clauses
->async_expr
);
3691 OMP_CLAUSE_ASYNC_EXPR (c
) = NULL
;
3692 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3696 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_SEQ
);
3697 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3699 if (clauses
->par_auto
)
3701 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_AUTO
);
3702 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3704 if (clauses
->if_present
)
3706 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_IF_PRESENT
);
3707 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3709 if (clauses
->finalize
)
3711 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_FINALIZE
);
3712 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3714 if (clauses
->independent
)
3716 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_INDEPENDENT
);
3717 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3719 if (clauses
->wait_list
)
3723 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3725 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WAIT
);
3726 OMP_CLAUSE_DECL (c
) = gfc_convert_expr_to_tree (block
, el
->expr
);
3727 OMP_CLAUSE_CHAIN (c
) = omp_clauses
;
3731 if (clauses
->num_gangs_expr
)
3734 = gfc_convert_expr_to_tree (block
, clauses
->num_gangs_expr
);
3735 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_GANGS
);
3736 OMP_CLAUSE_NUM_GANGS_EXPR (c
) = num_gangs_var
;
3737 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3739 if (clauses
->num_workers_expr
)
3741 tree num_workers_var
3742 = gfc_convert_expr_to_tree (block
, clauses
->num_workers_expr
);
3743 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_NUM_WORKERS
);
3744 OMP_CLAUSE_NUM_WORKERS_EXPR (c
) = num_workers_var
;
3745 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3747 if (clauses
->vector_length_expr
)
3749 tree vector_length_var
3750 = gfc_convert_expr_to_tree (block
, clauses
->vector_length_expr
);
3751 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR_LENGTH
);
3752 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c
) = vector_length_var
;
3753 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3755 if (clauses
->tile_list
)
3757 vec
<tree
, va_gc
> *tvec
;
3760 vec_alloc (tvec
, 4);
3762 for (el
= clauses
->tile_list
; el
; el
= el
->next
)
3763 vec_safe_push (tvec
, gfc_convert_expr_to_tree (block
, el
->expr
));
3765 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_TILE
);
3766 OMP_CLAUSE_TILE_LIST (c
) = build_tree_list_vec (tvec
);
3767 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3770 if (clauses
->vector
)
3772 if (clauses
->vector_expr
)
3775 = gfc_convert_expr_to_tree (block
, clauses
->vector_expr
);
3776 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR
);
3777 OMP_CLAUSE_VECTOR_EXPR (c
) = vector_var
;
3778 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3782 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_VECTOR
);
3783 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3786 if (clauses
->worker
)
3788 if (clauses
->worker_expr
)
3791 = gfc_convert_expr_to_tree (block
, clauses
->worker_expr
);
3792 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WORKER
);
3793 OMP_CLAUSE_WORKER_EXPR (c
) = worker_var
;
3794 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3798 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_WORKER
);
3799 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3805 c
= build_omp_clause (gfc_get_location (&where
), OMP_CLAUSE_GANG
);
3806 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
3807 if (clauses
->gang_num_expr
)
3809 arg
= gfc_convert_expr_to_tree (block
, clauses
->gang_num_expr
);
3810 OMP_CLAUSE_GANG_EXPR (c
) = arg
;
3812 if (clauses
->gang_static
)
3814 arg
= clauses
->gang_static_expr
3815 ? gfc_convert_expr_to_tree (block
, clauses
->gang_static_expr
)
3816 : integer_minus_one_node
;
3817 OMP_CLAUSE_GANG_STATIC_EXPR (c
) = arg
;
3821 return nreverse (omp_clauses
);
3824 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
3827 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
3832 stmt
= gfc_trans_code (code
);
3833 if (TREE_CODE (stmt
) != BIND_EXPR
)
3835 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
3837 tree block
= poplevel (1, 0);
3838 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
3848 /* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
3852 gfc_trans_oacc_construct (gfc_code
*code
)
3855 tree stmt
, oacc_clauses
;
3856 enum tree_code construct_code
;
3860 case EXEC_OACC_PARALLEL
:
3861 construct_code
= OACC_PARALLEL
;
3863 case EXEC_OACC_KERNELS
:
3864 construct_code
= OACC_KERNELS
;
3866 case EXEC_OACC_SERIAL
:
3867 construct_code
= OACC_SERIAL
;
3869 case EXEC_OACC_DATA
:
3870 construct_code
= OACC_DATA
;
3872 case EXEC_OACC_HOST_DATA
:
3873 construct_code
= OACC_HOST_DATA
;
3879 gfc_start_block (&block
);
3880 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3881 code
->loc
, false, true);
3882 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
3883 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
3885 gfc_add_expr_to_block (&block
, stmt
);
3886 return gfc_finish_block (&block
);
3889 /* update, enter_data, exit_data, cache. */
3891 gfc_trans_oacc_executable_directive (gfc_code
*code
)
3894 tree stmt
, oacc_clauses
;
3895 enum tree_code construct_code
;
3899 case EXEC_OACC_UPDATE
:
3900 construct_code
= OACC_UPDATE
;
3902 case EXEC_OACC_ENTER_DATA
:
3903 construct_code
= OACC_ENTER_DATA
;
3905 case EXEC_OACC_EXIT_DATA
:
3906 construct_code
= OACC_EXIT_DATA
;
3908 case EXEC_OACC_CACHE
:
3909 construct_code
= OACC_CACHE
;
3915 gfc_start_block (&block
);
3916 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3917 code
->loc
, false, true);
3918 stmt
= build1_loc (input_location
, construct_code
, void_type_node
,
3920 gfc_add_expr_to_block (&block
, stmt
);
3921 return gfc_finish_block (&block
);
3925 gfc_trans_oacc_wait_directive (gfc_code
*code
)
3929 vec
<tree
, va_gc
> *args
;
3932 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
3933 location_t loc
= input_location
;
3935 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3938 vec_alloc (args
, nparms
+ 2);
3939 stmt
= builtin_decl_explicit (BUILT_IN_GOACC_WAIT
);
3941 gfc_start_block (&block
);
3943 if (clauses
->async_expr
)
3944 t
= gfc_convert_expr_to_tree (&block
, clauses
->async_expr
);
3946 t
= build_int_cst (integer_type_node
, -2);
3948 args
->quick_push (t
);
3949 args
->quick_push (build_int_cst (integer_type_node
, nparms
));
3951 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
3952 args
->quick_push (gfc_convert_expr_to_tree (&block
, el
->expr
));
3954 stmt
= build_call_expr_loc_vec (loc
, stmt
, args
);
3955 gfc_add_expr_to_block (&block
, stmt
);
3959 return gfc_finish_block (&block
);
3962 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
3963 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
3966 gfc_trans_omp_atomic (gfc_code
*code
)
3968 gfc_code
*atomic_code
= code
;
3972 gfc_expr
*expr2
, *e
;
3975 tree lhsaddr
, type
, rhs
, x
;
3976 enum tree_code op
= ERROR_MARK
;
3977 enum tree_code aop
= OMP_ATOMIC
;
3978 bool var_on_left
= false;
3979 enum omp_memory_order mo
;
3980 if (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SEQ_CST
)
3981 mo
= OMP_MEMORY_ORDER_SEQ_CST
;
3982 else if (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_ACQ_REL
)
3983 mo
= OMP_MEMORY_ORDER_ACQ_REL
;
3985 mo
= OMP_MEMORY_ORDER_RELAXED
;
3987 code
= code
->block
->next
;
3988 gcc_assert (code
->op
== EXEC_ASSIGN
);
3989 var
= code
->expr1
->symtree
->n
.sym
;
3991 gfc_init_se (&lse
, NULL
);
3992 gfc_init_se (&rse
, NULL
);
3993 gfc_init_se (&vse
, NULL
);
3994 gfc_start_block (&block
);
3996 expr2
= code
->expr2
;
3997 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3998 != GFC_OMP_ATOMIC_WRITE
)
3999 && expr2
->expr_type
== EXPR_FUNCTION
4000 && expr2
->value
.function
.isym
4001 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4002 expr2
= expr2
->value
.function
.actual
->expr
;
4004 switch (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4006 case GFC_OMP_ATOMIC_READ
:
4007 gfc_conv_expr (&vse
, code
->expr1
);
4008 gfc_add_block_to_block (&block
, &vse
.pre
);
4010 gfc_conv_expr (&lse
, expr2
);
4011 gfc_add_block_to_block (&block
, &lse
.pre
);
4012 type
= TREE_TYPE (lse
.expr
);
4013 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
4015 x
= build1 (OMP_ATOMIC_READ
, type
, lhsaddr
);
4016 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4017 x
= convert (TREE_TYPE (vse
.expr
), x
);
4018 gfc_add_modify (&block
, vse
.expr
, x
);
4020 gfc_add_block_to_block (&block
, &lse
.pre
);
4021 gfc_add_block_to_block (&block
, &rse
.pre
);
4023 return gfc_finish_block (&block
);
4024 case GFC_OMP_ATOMIC_CAPTURE
:
4025 aop
= OMP_ATOMIC_CAPTURE_NEW
;
4026 if (expr2
->expr_type
== EXPR_VARIABLE
)
4028 aop
= OMP_ATOMIC_CAPTURE_OLD
;
4029 gfc_conv_expr (&vse
, code
->expr1
);
4030 gfc_add_block_to_block (&block
, &vse
.pre
);
4032 gfc_conv_expr (&lse
, expr2
);
4033 gfc_add_block_to_block (&block
, &lse
.pre
);
4034 gfc_init_se (&lse
, NULL
);
4036 var
= code
->expr1
->symtree
->n
.sym
;
4037 expr2
= code
->expr2
;
4038 if (expr2
->expr_type
== EXPR_FUNCTION
4039 && expr2
->value
.function
.isym
4040 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4041 expr2
= expr2
->value
.function
.actual
->expr
;
4048 gfc_conv_expr (&lse
, code
->expr1
);
4049 gfc_add_block_to_block (&block
, &lse
.pre
);
4050 type
= TREE_TYPE (lse
.expr
);
4051 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
4053 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4054 == GFC_OMP_ATOMIC_WRITE
)
4055 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
4057 gfc_conv_expr (&rse
, expr2
);
4058 gfc_add_block_to_block (&block
, &rse
.pre
);
4060 else if (expr2
->expr_type
== EXPR_OP
)
4063 switch (expr2
->value
.op
.op
)
4065 case INTRINSIC_PLUS
:
4068 case INTRINSIC_TIMES
:
4071 case INTRINSIC_MINUS
:
4074 case INTRINSIC_DIVIDE
:
4075 if (expr2
->ts
.type
== BT_INTEGER
)
4076 op
= TRUNC_DIV_EXPR
;
4081 op
= TRUTH_ANDIF_EXPR
;
4084 op
= TRUTH_ORIF_EXPR
;
4089 case INTRINSIC_NEQV
:
4095 e
= expr2
->value
.op
.op1
;
4096 if (e
->expr_type
== EXPR_FUNCTION
4097 && e
->value
.function
.isym
4098 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4099 e
= e
->value
.function
.actual
->expr
;
4100 if (e
->expr_type
== EXPR_VARIABLE
4101 && e
->symtree
!= NULL
4102 && e
->symtree
->n
.sym
== var
)
4104 expr2
= expr2
->value
.op
.op2
;
4109 e
= expr2
->value
.op
.op2
;
4110 if (e
->expr_type
== EXPR_FUNCTION
4111 && e
->value
.function
.isym
4112 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4113 e
= e
->value
.function
.actual
->expr
;
4114 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4115 && e
->symtree
!= NULL
4116 && e
->symtree
->n
.sym
== var
);
4117 expr2
= expr2
->value
.op
.op1
;
4118 var_on_left
= false;
4120 gfc_conv_expr (&rse
, expr2
);
4121 gfc_add_block_to_block (&block
, &rse
.pre
);
4125 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
4126 switch (expr2
->value
.function
.isym
->id
)
4146 e
= expr2
->value
.function
.actual
->expr
;
4147 gcc_assert (e
->expr_type
== EXPR_VARIABLE
4148 && e
->symtree
!= NULL
4149 && e
->symtree
->n
.sym
== var
);
4151 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
4152 gfc_add_block_to_block (&block
, &rse
.pre
);
4153 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
4155 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
4156 gfc_actual_arglist
*arg
;
4158 gfc_add_modify (&block
, accum
, rse
.expr
);
4159 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
4162 gfc_init_block (&rse
.pre
);
4163 gfc_conv_expr (&rse
, arg
->expr
);
4164 gfc_add_block_to_block (&block
, &rse
.pre
);
4165 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (accum
),
4167 gfc_add_modify (&block
, accum
, x
);
4173 expr2
= expr2
->value
.function
.actual
->next
->expr
;
4176 lhsaddr
= save_expr (lhsaddr
);
4177 if (TREE_CODE (lhsaddr
) != SAVE_EXPR
4178 && (TREE_CODE (lhsaddr
) != ADDR_EXPR
4179 || !VAR_P (TREE_OPERAND (lhsaddr
, 0))))
4181 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
4182 it even after unsharing function body. */
4183 tree var
= create_tmp_var_raw (TREE_TYPE (lhsaddr
));
4184 DECL_CONTEXT (var
) = current_function_decl
;
4185 lhsaddr
= build4 (TARGET_EXPR
, TREE_TYPE (lhsaddr
), var
, lhsaddr
,
4186 NULL_TREE
, NULL_TREE
);
4189 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
4191 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4192 == GFC_OMP_ATOMIC_WRITE
)
4193 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
4197 x
= convert (TREE_TYPE (rhs
),
4198 build_fold_indirect_ref_loc (input_location
, lhsaddr
));
4200 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), x
, rhs
);
4202 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), rhs
, x
);
4205 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
4206 && TREE_CODE (type
) != COMPLEX_TYPE
)
4207 x
= fold_build1_loc (input_location
, REALPART_EXPR
,
4208 TREE_TYPE (TREE_TYPE (rhs
)), x
);
4210 gfc_add_block_to_block (&block
, &lse
.pre
);
4211 gfc_add_block_to_block (&block
, &rse
.pre
);
4213 if (aop
== OMP_ATOMIC
)
4215 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
4216 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4217 gfc_add_expr_to_block (&block
, x
);
4221 if (aop
== OMP_ATOMIC_CAPTURE_NEW
)
4224 expr2
= code
->expr2
;
4225 if (expr2
->expr_type
== EXPR_FUNCTION
4226 && expr2
->value
.function
.isym
4227 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
4228 expr2
= expr2
->value
.function
.actual
->expr
;
4230 gcc_assert (expr2
->expr_type
== EXPR_VARIABLE
);
4231 gfc_conv_expr (&vse
, code
->expr1
);
4232 gfc_add_block_to_block (&block
, &vse
.pre
);
4234 gfc_init_se (&lse
, NULL
);
4235 gfc_conv_expr (&lse
, expr2
);
4236 gfc_add_block_to_block (&block
, &lse
.pre
);
4238 x
= build2 (aop
, type
, lhsaddr
, convert (type
, x
));
4239 OMP_ATOMIC_MEMORY_ORDER (x
) = mo
;
4240 x
= convert (TREE_TYPE (vse
.expr
), x
);
4241 gfc_add_modify (&block
, vse
.expr
, x
);
4244 return gfc_finish_block (&block
);
4248 gfc_trans_omp_barrier (void)
4250 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_BARRIER
);
4251 return build_call_expr_loc (input_location
, decl
, 0);
4255 gfc_trans_omp_cancel (gfc_code
*code
)
4258 tree ifc
= boolean_true_node
;
4260 switch (code
->ext
.omp_clauses
->cancel
)
4262 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4263 case OMP_CANCEL_DO
: mask
= 2; break;
4264 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4265 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4266 default: gcc_unreachable ();
4268 gfc_start_block (&block
);
4269 if (code
->ext
.omp_clauses
->if_expr
4270 || code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
])
4275 gcc_assert ((code
->ext
.omp_clauses
->if_expr
== NULL
)
4276 ^ (code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
] == NULL
));
4277 gfc_init_se (&se
, NULL
);
4278 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->if_expr
!= NULL
4279 ? code
->ext
.omp_clauses
->if_expr
4280 : code
->ext
.omp_clauses
->if_exprs
[OMP_IF_CANCEL
]);
4281 gfc_add_block_to_block (&block
, &se
.pre
);
4282 if_var
= gfc_evaluate_now (se
.expr
, &block
);
4283 gfc_add_block_to_block (&block
, &se
.post
);
4284 tree type
= TREE_TYPE (if_var
);
4285 ifc
= fold_build2_loc (input_location
, NE_EXPR
,
4286 boolean_type_node
, if_var
,
4287 build_zero_cst (type
));
4289 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCEL
);
4290 tree c_bool_type
= TREE_TYPE (TREE_TYPE (decl
));
4291 ifc
= fold_convert (c_bool_type
, ifc
);
4292 gfc_add_expr_to_block (&block
,
4293 build_call_expr_loc (input_location
, decl
, 2,
4294 build_int_cst (integer_type_node
,
4296 return gfc_finish_block (&block
);
4300 gfc_trans_omp_cancellation_point (gfc_code
*code
)
4303 switch (code
->ext
.omp_clauses
->cancel
)
4305 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
4306 case OMP_CANCEL_DO
: mask
= 2; break;
4307 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
4308 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
4309 default: gcc_unreachable ();
4311 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT
);
4312 return build_call_expr_loc (input_location
, decl
, 1,
4313 build_int_cst (integer_type_node
, mask
));
4317 gfc_trans_omp_critical (gfc_code
*code
)
4320 tree stmt
, name
= NULL_TREE
;
4321 if (code
->ext
.omp_clauses
->critical_name
!= NULL
)
4322 name
= get_identifier (code
->ext
.omp_clauses
->critical_name
);
4323 gfc_start_block (&block
);
4324 stmt
= make_node (OMP_CRITICAL
);
4325 TREE_TYPE (stmt
) = void_type_node
;
4326 OMP_CRITICAL_BODY (stmt
) = gfc_trans_code (code
->block
->next
);
4327 OMP_CRITICAL_NAME (stmt
) = name
;
4328 OMP_CRITICAL_CLAUSES (stmt
) = gfc_trans_omp_clauses (&block
,
4329 code
->ext
.omp_clauses
,
4331 gfc_add_expr_to_block (&block
, stmt
);
4332 return gfc_finish_block (&block
);
4335 typedef struct dovar_init_d
{
4342 gfc_trans_omp_do (gfc_code
*code
, gfc_exec_op op
, stmtblock_t
*pblock
,
4343 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
4346 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
, orig_decls
;
4347 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
4350 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
4351 int i
, collapse
= clauses
->collapse
;
4352 vec
<dovar_init
> inits
= vNULL
;
4355 vec
<tree
, va_heap
, vl_embed
> *saved_doacross_steps
= doacross_steps
;
4356 gfc_expr_list
*tile
= do_clauses
? do_clauses
->tile_list
: clauses
->tile_list
;
4358 /* Both collapsed and tiled loops are lowered the same way. In
4359 OpenACC, those clauses are not compatible, so prioritize the tile
4360 clause, if present. */
4364 for (gfc_expr_list
*el
= tile
; el
; el
= el
->next
)
4368 doacross_steps
= NULL
;
4369 if (clauses
->orderedc
)
4370 collapse
= clauses
->orderedc
;
4374 code
= code
->block
->next
;
4375 gcc_assert (code
->op
== EXEC_DO
);
4377 init
= make_tree_vec (collapse
);
4378 cond
= make_tree_vec (collapse
);
4379 incr
= make_tree_vec (collapse
);
4380 orig_decls
= clauses
->orderedc
? make_tree_vec (collapse
) : NULL_TREE
;
4384 gfc_start_block (&block
);
4388 /* simd schedule modifier is only useful for composite do simd and other
4389 constructs including that, where gfc_trans_omp_do is only called
4390 on the simd construct and DO's clauses are translated elsewhere. */
4391 do_clauses
->sched_simd
= false;
4393 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
4395 for (i
= 0; i
< collapse
; i
++)
4398 int dovar_found
= 0;
4403 gfc_omp_namelist
*n
= NULL
;
4404 if (op
!= EXEC_OMP_DISTRIBUTE
)
4405 for (n
= clauses
->lists
[(op
== EXEC_OMP_SIMD
&& collapse
== 1)
4406 ? OMP_LIST_LINEAR
: OMP_LIST_LASTPRIVATE
];
4407 n
!= NULL
; n
= n
->next
)
4408 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4412 else if (n
== NULL
&& op
!= EXEC_OMP_SIMD
)
4413 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
4414 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
4420 /* Evaluate all the expressions in the iterator. */
4421 gfc_init_se (&se
, NULL
);
4422 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
4423 gfc_add_block_to_block (pblock
, &se
.pre
);
4425 type
= TREE_TYPE (dovar
);
4426 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
4428 gfc_init_se (&se
, NULL
);
4429 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
4430 gfc_add_block_to_block (pblock
, &se
.pre
);
4431 from
= gfc_evaluate_now (se
.expr
, pblock
);
4433 gfc_init_se (&se
, NULL
);
4434 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
4435 gfc_add_block_to_block (pblock
, &se
.pre
);
4436 to
= gfc_evaluate_now (se
.expr
, pblock
);
4438 gfc_init_se (&se
, NULL
);
4439 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
4440 gfc_add_block_to_block (pblock
, &se
.pre
);
4441 step
= gfc_evaluate_now (se
.expr
, pblock
);
4444 /* Special case simple loops. */
4447 if (integer_onep (step
))
4449 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
4454 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
,
4460 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
4461 /* The condition should not be folded. */
4462 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, simple
> 0
4463 ? LE_EXPR
: GE_EXPR
,
4464 logical_type_node
, dovar
, to
);
4465 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
4467 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
4470 TREE_VEC_ELT (incr
, i
));
4474 /* STEP is not 1 or -1. Use:
4475 for (count = 0; count < (to + step - from) / step; count++)
4477 dovar = from + count * step;
4481 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, step
, from
);
4482 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, to
, tmp
);
4483 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
, tmp
,
4485 tmp
= gfc_evaluate_now (tmp
, pblock
);
4486 count
= gfc_create_var (type
, "count");
4487 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
4488 build_int_cst (type
, 0));
4489 /* The condition should not be folded. */
4490 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, LT_EXPR
,
4493 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
4495 build_int_cst (type
, 1));
4496 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
4497 MODIFY_EXPR
, type
, count
,
4498 TREE_VEC_ELT (incr
, i
));
4500 /* Initialize DOVAR. */
4501 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, count
, step
);
4502 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, from
, tmp
);
4503 dovar_init e
= {dovar
, tmp
};
4504 inits
.safe_push (e
);
4505 if (clauses
->orderedc
)
4507 if (doacross_steps
== NULL
)
4508 vec_safe_grow_cleared (doacross_steps
, clauses
->orderedc
, true);
4509 (*doacross_steps
)[i
] = step
;
4513 TREE_VEC_ELT (orig_decls
, i
) = dovar_decl
;
4515 if (dovar_found
== 2
4516 && op
== EXEC_OMP_SIMD
4520 for (tmp
= omp_clauses
; tmp
; tmp
= OMP_CLAUSE_CHAIN (tmp
))
4521 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_LINEAR
4522 && OMP_CLAUSE_DECL (tmp
) == dovar
)
4524 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4528 if (!dovar_found
&& op
== EXEC_OMP_SIMD
)
4532 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
4533 OMP_CLAUSE_LINEAR_STEP (tmp
) = step
;
4534 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4535 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
4536 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4541 else if (!dovar_found
&& !simple
)
4543 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
4544 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
4545 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4547 if (dovar_found
== 2)
4554 /* If dovar is lastprivate, but different counter is used,
4555 dovar += step needs to be added to
4556 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
4557 will have the value on entry of the last loop, rather
4558 than value after iterator increment. */
4559 if (clauses
->orderedc
)
4561 if (clauses
->collapse
<= 1 || i
>= clauses
->collapse
)
4564 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4565 type
, count
, build_one_cst (type
));
4566 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
4568 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
4573 tmp
= gfc_evaluate_now (step
, pblock
);
4574 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
4577 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
,
4579 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
4580 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
4581 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4583 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
4586 else if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LINEAR
4587 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4589 OMP_CLAUSE_LINEAR_STMT (c
) = tmp
;
4593 if (c
== NULL
&& op
== EXEC_OMP_DO
&& par_clauses
!= NULL
)
4595 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
4596 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
4597 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
4599 tree l
= build_omp_clause (input_location
,
4600 OMP_CLAUSE_LASTPRIVATE
);
4601 if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c
))
4602 OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l
) = 1;
4603 OMP_CLAUSE_DECL (l
) = dovar_decl
;
4604 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
4605 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
4607 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
4611 gcc_assert (simple
|| c
!= NULL
);
4615 if (op
!= EXEC_OMP_SIMD
)
4616 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
4617 else if (collapse
== 1)
4619 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
4620 OMP_CLAUSE_LINEAR_STEP (tmp
) = build_int_cst (type
, 1);
4621 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
4622 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp
) = 1;
4625 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
4626 OMP_CLAUSE_DECL (tmp
) = count
;
4627 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
4630 if (i
+ 1 < collapse
)
4631 code
= code
->block
->next
;
4634 if (pblock
!= &block
)
4637 gfc_start_block (&block
);
4640 gfc_start_block (&body
);
4642 FOR_EACH_VEC_ELT (inits
, ix
, di
)
4643 gfc_add_modify (&body
, di
->var
, di
->init
);
4646 /* Cycle statement is implemented with a goto. Exit statement must not be
4647 present for this loop. */
4648 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4650 /* Put these labels where they can be found later. */
4652 code
->cycle_label
= cycle_label
;
4653 code
->exit_label
= NULL_TREE
;
4655 /* Main loop body. */
4656 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
4657 gfc_add_expr_to_block (&body
, tmp
);
4659 /* Label for cycle statements (if needed). */
4660 if (TREE_USED (cycle_label
))
4662 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4663 gfc_add_expr_to_block (&body
, tmp
);
4666 /* End of loop body. */
4669 case EXEC_OMP_SIMD
: stmt
= make_node (OMP_SIMD
); break;
4670 case EXEC_OMP_DO
: stmt
= make_node (OMP_FOR
); break;
4671 case EXEC_OMP_DISTRIBUTE
: stmt
= make_node (OMP_DISTRIBUTE
); break;
4672 case EXEC_OMP_TASKLOOP
: stmt
= make_node (OMP_TASKLOOP
); break;
4673 case EXEC_OACC_LOOP
: stmt
= make_node (OACC_LOOP
); break;
4674 default: gcc_unreachable ();
4677 TREE_TYPE (stmt
) = void_type_node
;
4678 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
4679 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
4680 OMP_FOR_INIT (stmt
) = init
;
4681 OMP_FOR_COND (stmt
) = cond
;
4682 OMP_FOR_INCR (stmt
) = incr
;
4684 OMP_FOR_ORIG_DECLS (stmt
) = orig_decls
;
4685 gfc_add_expr_to_block (&block
, stmt
);
4687 vec_free (doacross_steps
);
4688 doacross_steps
= saved_doacross_steps
;
4690 return gfc_finish_block (&block
);
4693 /* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
4697 gfc_trans_oacc_combined_directive (gfc_code
*code
)
4699 stmtblock_t block
, *pblock
= NULL
;
4700 gfc_omp_clauses construct_clauses
, loop_clauses
;
4701 tree stmt
, oacc_clauses
= NULL_TREE
;
4702 enum tree_code construct_code
;
4703 location_t loc
= input_location
;
4707 case EXEC_OACC_PARALLEL_LOOP
:
4708 construct_code
= OACC_PARALLEL
;
4710 case EXEC_OACC_KERNELS_LOOP
:
4711 construct_code
= OACC_KERNELS
;
4713 case EXEC_OACC_SERIAL_LOOP
:
4714 construct_code
= OACC_SERIAL
;
4720 gfc_start_block (&block
);
4722 memset (&loop_clauses
, 0, sizeof (loop_clauses
));
4723 if (code
->ext
.omp_clauses
!= NULL
)
4725 memcpy (&construct_clauses
, code
->ext
.omp_clauses
,
4726 sizeof (construct_clauses
));
4727 loop_clauses
.collapse
= construct_clauses
.collapse
;
4728 loop_clauses
.gang
= construct_clauses
.gang
;
4729 loop_clauses
.gang_static
= construct_clauses
.gang_static
;
4730 loop_clauses
.gang_num_expr
= construct_clauses
.gang_num_expr
;
4731 loop_clauses
.gang_static_expr
= construct_clauses
.gang_static_expr
;
4732 loop_clauses
.vector
= construct_clauses
.vector
;
4733 loop_clauses
.vector_expr
= construct_clauses
.vector_expr
;
4734 loop_clauses
.worker
= construct_clauses
.worker
;
4735 loop_clauses
.worker_expr
= construct_clauses
.worker_expr
;
4736 loop_clauses
.seq
= construct_clauses
.seq
;
4737 loop_clauses
.par_auto
= construct_clauses
.par_auto
;
4738 loop_clauses
.independent
= construct_clauses
.independent
;
4739 loop_clauses
.tile_list
= construct_clauses
.tile_list
;
4740 loop_clauses
.lists
[OMP_LIST_PRIVATE
]
4741 = construct_clauses
.lists
[OMP_LIST_PRIVATE
];
4742 loop_clauses
.lists
[OMP_LIST_REDUCTION
]
4743 = construct_clauses
.lists
[OMP_LIST_REDUCTION
];
4744 construct_clauses
.gang
= false;
4745 construct_clauses
.gang_static
= false;
4746 construct_clauses
.gang_num_expr
= NULL
;
4747 construct_clauses
.gang_static_expr
= NULL
;
4748 construct_clauses
.vector
= false;
4749 construct_clauses
.vector_expr
= NULL
;
4750 construct_clauses
.worker
= false;
4751 construct_clauses
.worker_expr
= NULL
;
4752 construct_clauses
.seq
= false;
4753 construct_clauses
.par_auto
= false;
4754 construct_clauses
.independent
= false;
4755 construct_clauses
.independent
= false;
4756 construct_clauses
.tile_list
= NULL
;
4757 construct_clauses
.lists
[OMP_LIST_PRIVATE
] = NULL
;
4758 if (construct_code
== OACC_KERNELS
)
4759 construct_clauses
.lists
[OMP_LIST_REDUCTION
] = NULL
;
4760 oacc_clauses
= gfc_trans_omp_clauses (&block
, &construct_clauses
,
4761 code
->loc
, false, true);
4763 if (!loop_clauses
.seq
)
4767 stmt
= gfc_trans_omp_do (code
, EXEC_OACC_LOOP
, pblock
, &loop_clauses
, NULL
);
4768 protected_set_expr_location (stmt
, loc
);
4769 if (TREE_CODE (stmt
) != BIND_EXPR
)
4770 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4773 stmt
= build2_loc (loc
, construct_code
, void_type_node
, stmt
, oacc_clauses
);
4774 gfc_add_expr_to_block (&block
, stmt
);
4775 return gfc_finish_block (&block
);
4779 gfc_trans_omp_flush (void)
4781 tree decl
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
4782 return build_call_expr_loc (input_location
, decl
, 0);
4786 gfc_trans_omp_master (gfc_code
*code
)
4788 tree stmt
= gfc_trans_code (code
->block
->next
);
4789 if (IS_EMPTY_STMT (stmt
))
4791 return build1_v (OMP_MASTER
, stmt
);
4795 gfc_trans_omp_ordered (gfc_code
*code
)
4799 if (!code
->ext
.omp_clauses
->simd
)
4800 return gfc_trans_code (code
->block
? code
->block
->next
: NULL
);
4801 code
->ext
.omp_clauses
->threads
= 0;
4803 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, code
->ext
.omp_clauses
,
4805 return build2_loc (input_location
, OMP_ORDERED
, void_type_node
,
4806 code
->block
? gfc_trans_code (code
->block
->next
)
4807 : NULL_TREE
, omp_clauses
);
4811 gfc_trans_omp_parallel (gfc_code
*code
)
4814 tree stmt
, omp_clauses
;
4816 gfc_start_block (&block
);
4817 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4820 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4821 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4822 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4824 gfc_add_expr_to_block (&block
, stmt
);
4825 return gfc_finish_block (&block
);
4832 GFC_OMP_SPLIT_PARALLEL
,
4833 GFC_OMP_SPLIT_DISTRIBUTE
,
4834 GFC_OMP_SPLIT_TEAMS
,
4835 GFC_OMP_SPLIT_TARGET
,
4836 GFC_OMP_SPLIT_TASKLOOP
,
4842 GFC_OMP_MASK_SIMD
= (1 << GFC_OMP_SPLIT_SIMD
),
4843 GFC_OMP_MASK_DO
= (1 << GFC_OMP_SPLIT_DO
),
4844 GFC_OMP_MASK_PARALLEL
= (1 << GFC_OMP_SPLIT_PARALLEL
),
4845 GFC_OMP_MASK_DISTRIBUTE
= (1 << GFC_OMP_SPLIT_DISTRIBUTE
),
4846 GFC_OMP_MASK_TEAMS
= (1 << GFC_OMP_SPLIT_TEAMS
),
4847 GFC_OMP_MASK_TARGET
= (1 << GFC_OMP_SPLIT_TARGET
),
4848 GFC_OMP_MASK_TASKLOOP
= (1 << GFC_OMP_SPLIT_TASKLOOP
)
4852 gfc_split_omp_clauses (gfc_code
*code
,
4853 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
])
4855 int mask
= 0, innermost
= 0;
4856 memset (clausesa
, 0, GFC_OMP_SPLIT_NUM
* sizeof (gfc_omp_clauses
));
4859 case EXEC_OMP_DISTRIBUTE
:
4860 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4862 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4863 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4864 innermost
= GFC_OMP_SPLIT_DO
;
4866 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4867 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
4868 | GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4869 innermost
= GFC_OMP_SPLIT_SIMD
;
4871 case EXEC_OMP_DISTRIBUTE_SIMD
:
4872 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4873 innermost
= GFC_OMP_SPLIT_SIMD
;
4876 innermost
= GFC_OMP_SPLIT_DO
;
4878 case EXEC_OMP_DO_SIMD
:
4879 mask
= GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4880 innermost
= GFC_OMP_SPLIT_SIMD
;
4882 case EXEC_OMP_PARALLEL
:
4883 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4885 case EXEC_OMP_PARALLEL_DO
:
4886 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4887 innermost
= GFC_OMP_SPLIT_DO
;
4889 case EXEC_OMP_PARALLEL_DO_SIMD
:
4890 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4891 innermost
= GFC_OMP_SPLIT_SIMD
;
4894 innermost
= GFC_OMP_SPLIT_SIMD
;
4896 case EXEC_OMP_TARGET
:
4897 innermost
= GFC_OMP_SPLIT_TARGET
;
4899 case EXEC_OMP_TARGET_PARALLEL
:
4900 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
;
4901 innermost
= GFC_OMP_SPLIT_PARALLEL
;
4903 case EXEC_OMP_TARGET_PARALLEL_DO
:
4904 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4905 innermost
= GFC_OMP_SPLIT_DO
;
4907 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4908 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
4909 | GFC_OMP_MASK_SIMD
;
4910 innermost
= GFC_OMP_SPLIT_SIMD
;
4912 case EXEC_OMP_TARGET_SIMD
:
4913 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_SIMD
;
4914 innermost
= GFC_OMP_SPLIT_SIMD
;
4916 case EXEC_OMP_TARGET_TEAMS
:
4917 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
;
4918 innermost
= GFC_OMP_SPLIT_TEAMS
;
4920 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4921 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4922 | GFC_OMP_MASK_DISTRIBUTE
;
4923 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4925 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4926 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4927 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4928 innermost
= GFC_OMP_SPLIT_DO
;
4930 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4931 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4932 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4933 innermost
= GFC_OMP_SPLIT_SIMD
;
4935 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4936 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
4937 | GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4938 innermost
= GFC_OMP_SPLIT_SIMD
;
4940 case EXEC_OMP_TASKLOOP
:
4941 innermost
= GFC_OMP_SPLIT_TASKLOOP
;
4943 case EXEC_OMP_TASKLOOP_SIMD
:
4944 mask
= GFC_OMP_MASK_TASKLOOP
| GFC_OMP_MASK_SIMD
;
4945 innermost
= GFC_OMP_SPLIT_SIMD
;
4947 case EXEC_OMP_TEAMS
:
4948 innermost
= GFC_OMP_SPLIT_TEAMS
;
4950 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4951 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
;
4952 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
4954 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4955 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4956 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
4957 innermost
= GFC_OMP_SPLIT_DO
;
4959 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4960 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
4961 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
4962 innermost
= GFC_OMP_SPLIT_SIMD
;
4964 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4965 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
4966 innermost
= GFC_OMP_SPLIT_SIMD
;
4973 clausesa
[innermost
] = *code
->ext
.omp_clauses
;
4976 if (code
->ext
.omp_clauses
!= NULL
)
4978 if (mask
& GFC_OMP_MASK_TARGET
)
4980 /* First the clauses that are unique to some constructs. */
4981 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_MAP
]
4982 = code
->ext
.omp_clauses
->lists
[OMP_LIST_MAP
];
4983 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_IS_DEVICE_PTR
]
4984 = code
->ext
.omp_clauses
->lists
[OMP_LIST_IS_DEVICE_PTR
];
4985 clausesa
[GFC_OMP_SPLIT_TARGET
].device
4986 = code
->ext
.omp_clauses
->device
;
4987 clausesa
[GFC_OMP_SPLIT_TARGET
].defaultmap
4988 = code
->ext
.omp_clauses
->defaultmap
;
4989 clausesa
[GFC_OMP_SPLIT_TARGET
].if_exprs
[OMP_IF_TARGET
]
4990 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TARGET
];
4991 /* And this is copied to all. */
4992 clausesa
[GFC_OMP_SPLIT_TARGET
].if_expr
4993 = code
->ext
.omp_clauses
->if_expr
;
4995 if (mask
& GFC_OMP_MASK_TEAMS
)
4997 /* First the clauses that are unique to some constructs. */
4998 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
4999 = code
->ext
.omp_clauses
->num_teams
;
5000 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
5001 = code
->ext
.omp_clauses
->thread_limit
;
5002 /* Shared and default clauses are allowed on parallel, teams
5004 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_SHARED
]
5005 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5006 clausesa
[GFC_OMP_SPLIT_TEAMS
].default_sharing
5007 = code
->ext
.omp_clauses
->default_sharing
;
5009 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5011 /* First the clauses that are unique to some constructs. */
5012 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_sched_kind
5013 = code
->ext
.omp_clauses
->dist_sched_kind
;
5014 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_chunk_size
5015 = code
->ext
.omp_clauses
->dist_chunk_size
;
5016 /* Duplicate collapse. */
5017 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].collapse
5018 = code
->ext
.omp_clauses
->collapse
;
5019 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].order_concurrent
5020 = code
->ext
.omp_clauses
->order_concurrent
;
5022 if (mask
& GFC_OMP_MASK_PARALLEL
)
5024 /* First the clauses that are unique to some constructs. */
5025 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_COPYIN
]
5026 = code
->ext
.omp_clauses
->lists
[OMP_LIST_COPYIN
];
5027 clausesa
[GFC_OMP_SPLIT_PARALLEL
].num_threads
5028 = code
->ext
.omp_clauses
->num_threads
;
5029 clausesa
[GFC_OMP_SPLIT_PARALLEL
].proc_bind
5030 = code
->ext
.omp_clauses
->proc_bind
;
5031 /* Shared and default clauses are allowed on parallel, teams
5033 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_SHARED
]
5034 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5035 clausesa
[GFC_OMP_SPLIT_PARALLEL
].default_sharing
5036 = code
->ext
.omp_clauses
->default_sharing
;
5037 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_exprs
[OMP_IF_PARALLEL
]
5038 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_PARALLEL
];
5039 /* And this is copied to all. */
5040 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
5041 = code
->ext
.omp_clauses
->if_expr
;
5043 if (mask
& GFC_OMP_MASK_DO
)
5045 /* First the clauses that are unique to some constructs. */
5046 clausesa
[GFC_OMP_SPLIT_DO
].ordered
5047 = code
->ext
.omp_clauses
->ordered
;
5048 clausesa
[GFC_OMP_SPLIT_DO
].orderedc
5049 = code
->ext
.omp_clauses
->orderedc
;
5050 clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
5051 = code
->ext
.omp_clauses
->sched_kind
;
5052 if (innermost
== GFC_OMP_SPLIT_SIMD
)
5053 clausesa
[GFC_OMP_SPLIT_DO
].sched_simd
5054 = code
->ext
.omp_clauses
->sched_simd
;
5055 clausesa
[GFC_OMP_SPLIT_DO
].sched_monotonic
5056 = code
->ext
.omp_clauses
->sched_monotonic
;
5057 clausesa
[GFC_OMP_SPLIT_DO
].sched_nonmonotonic
5058 = code
->ext
.omp_clauses
->sched_nonmonotonic
;
5059 clausesa
[GFC_OMP_SPLIT_DO
].chunk_size
5060 = code
->ext
.omp_clauses
->chunk_size
;
5061 clausesa
[GFC_OMP_SPLIT_DO
].nowait
5062 = code
->ext
.omp_clauses
->nowait
;
5063 /* Duplicate collapse. */
5064 clausesa
[GFC_OMP_SPLIT_DO
].collapse
5065 = code
->ext
.omp_clauses
->collapse
;
5066 clausesa
[GFC_OMP_SPLIT_DO
].order_concurrent
5067 = code
->ext
.omp_clauses
->order_concurrent
;
5069 if (mask
& GFC_OMP_MASK_SIMD
)
5071 clausesa
[GFC_OMP_SPLIT_SIMD
].safelen_expr
5072 = code
->ext
.omp_clauses
->safelen_expr
;
5073 clausesa
[GFC_OMP_SPLIT_SIMD
].simdlen_expr
5074 = code
->ext
.omp_clauses
->simdlen_expr
;
5075 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_ALIGNED
]
5076 = code
->ext
.omp_clauses
->lists
[OMP_LIST_ALIGNED
];
5077 /* Duplicate collapse. */
5078 clausesa
[GFC_OMP_SPLIT_SIMD
].collapse
5079 = code
->ext
.omp_clauses
->collapse
;
5080 clausesa
[GFC_OMP_SPLIT_SIMD
].if_exprs
[OMP_IF_SIMD
]
5081 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_SIMD
];
5082 clausesa
[GFC_OMP_SPLIT_SIMD
].order_concurrent
5083 = code
->ext
.omp_clauses
->order_concurrent
;
5084 /* And this is copied to all. */
5085 clausesa
[GFC_OMP_SPLIT_SIMD
].if_expr
5086 = code
->ext
.omp_clauses
->if_expr
;
5088 if (mask
& GFC_OMP_MASK_TASKLOOP
)
5090 /* First the clauses that are unique to some constructs. */
5091 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].nogroup
5092 = code
->ext
.omp_clauses
->nogroup
;
5093 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].grainsize
5094 = code
->ext
.omp_clauses
->grainsize
;
5095 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].num_tasks
5096 = code
->ext
.omp_clauses
->num_tasks
;
5097 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].priority
5098 = code
->ext
.omp_clauses
->priority
;
5099 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].final_expr
5100 = code
->ext
.omp_clauses
->final_expr
;
5101 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].untied
5102 = code
->ext
.omp_clauses
->untied
;
5103 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].mergeable
5104 = code
->ext
.omp_clauses
->mergeable
;
5105 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_exprs
[OMP_IF_TASKLOOP
]
5106 = code
->ext
.omp_clauses
->if_exprs
[OMP_IF_TASKLOOP
];
5107 /* And this is copied to all. */
5108 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].if_expr
5109 = code
->ext
.omp_clauses
->if_expr
;
5110 /* Shared and default clauses are allowed on parallel, teams
5112 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].lists
[OMP_LIST_SHARED
]
5113 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
5114 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].default_sharing
5115 = code
->ext
.omp_clauses
->default_sharing
;
5116 /* Duplicate collapse. */
5117 clausesa
[GFC_OMP_SPLIT_TASKLOOP
].collapse
5118 = code
->ext
.omp_clauses
->collapse
;
5120 /* Private clause is supported on all constructs,
5121 it is enough to put it on the innermost one. For
5122 !$ omp parallel do put it on parallel though,
5123 as that's what we did for OpenMP 3.1. */
5124 clausesa
[innermost
== GFC_OMP_SPLIT_DO
5125 ? (int) GFC_OMP_SPLIT_PARALLEL
5126 : innermost
].lists
[OMP_LIST_PRIVATE
]
5127 = code
->ext
.omp_clauses
->lists
[OMP_LIST_PRIVATE
];
5128 /* Firstprivate clause is supported on all constructs but
5129 simd. Put it on the outermost of those and duplicate
5130 on parallel and teams. */
5131 if (mask
& GFC_OMP_MASK_TARGET
)
5132 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_FIRSTPRIVATE
]
5133 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5134 if (mask
& GFC_OMP_MASK_TEAMS
)
5135 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_FIRSTPRIVATE
]
5136 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5137 else if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5138 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_FIRSTPRIVATE
]
5139 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5140 if (mask
& GFC_OMP_MASK_PARALLEL
)
5141 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_FIRSTPRIVATE
]
5142 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5143 else if (mask
& GFC_OMP_MASK_DO
)
5144 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_FIRSTPRIVATE
]
5145 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
5146 /* Lastprivate is allowed on distribute, do and simd.
5147 In parallel do{, simd} we actually want to put it on
5148 parallel rather than do. */
5149 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
5150 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_LASTPRIVATE
]
5151 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5152 if (mask
& GFC_OMP_MASK_PARALLEL
)
5153 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_LASTPRIVATE
]
5154 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5155 else if (mask
& GFC_OMP_MASK_DO
)
5156 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_LASTPRIVATE
]
5157 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5158 if (mask
& GFC_OMP_MASK_SIMD
)
5159 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LASTPRIVATE
]
5160 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
5161 /* Reduction is allowed on simd, do, parallel and teams.
5162 Duplicate it on all of them, but omit on do if
5163 parallel is present. */
5164 if (mask
& GFC_OMP_MASK_TEAMS
)
5165 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_REDUCTION
]
5166 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5167 if (mask
& GFC_OMP_MASK_PARALLEL
)
5168 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_REDUCTION
]
5169 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5170 else if (mask
& GFC_OMP_MASK_DO
)
5171 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_REDUCTION
]
5172 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5173 if (mask
& GFC_OMP_MASK_SIMD
)
5174 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_REDUCTION
]
5175 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
5176 /* Linear clause is supported on do and simd,
5177 put it on the innermost one. */
5178 clausesa
[innermost
].lists
[OMP_LIST_LINEAR
]
5179 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LINEAR
];
5181 if ((mask
& (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
5182 == (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
5183 clausesa
[GFC_OMP_SPLIT_DO
].nowait
= true;
5187 gfc_trans_omp_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
5188 gfc_omp_clauses
*clausesa
, tree omp_clauses
)
5191 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5192 tree stmt
, body
, omp_do_clauses
= NULL_TREE
;
5195 gfc_start_block (&block
);
5197 gfc_init_block (&block
);
5199 if (clausesa
== NULL
)
5201 clausesa
= clausesa_buf
;
5202 gfc_split_omp_clauses (code
, clausesa
);
5206 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DO
], code
->loc
);
5207 body
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, pblock
? pblock
: &block
,
5208 &clausesa
[GFC_OMP_SPLIT_SIMD
], omp_clauses
);
5211 if (TREE_CODE (body
) != BIND_EXPR
)
5212 body
= build3_v (BIND_EXPR
, NULL
, body
, poplevel (1, 0));
5216 else if (TREE_CODE (body
) != BIND_EXPR
)
5217 body
= build3_v (BIND_EXPR
, NULL
, body
, NULL_TREE
);
5220 stmt
= make_node (OMP_FOR
);
5221 TREE_TYPE (stmt
) = void_type_node
;
5222 OMP_FOR_BODY (stmt
) = body
;
5223 OMP_FOR_CLAUSES (stmt
) = omp_do_clauses
;
5227 gfc_add_expr_to_block (&block
, stmt
);
5228 return gfc_finish_block (&block
);
5232 gfc_trans_omp_parallel_do (gfc_code
*code
, stmtblock_t
*pblock
,
5233 gfc_omp_clauses
*clausesa
)
5235 stmtblock_t block
, *new_pblock
= pblock
;
5236 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5237 tree stmt
, omp_clauses
= NULL_TREE
;
5240 gfc_start_block (&block
);
5242 gfc_init_block (&block
);
5244 if (clausesa
== NULL
)
5246 clausesa
= clausesa_buf
;
5247 gfc_split_omp_clauses (code
, clausesa
);
5250 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5254 if (!clausesa
[GFC_OMP_SPLIT_DO
].ordered
5255 && clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
!= OMP_SCHED_STATIC
)
5256 new_pblock
= &block
;
5260 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DO
, new_pblock
,
5261 &clausesa
[GFC_OMP_SPLIT_DO
], omp_clauses
);
5264 if (TREE_CODE (stmt
) != BIND_EXPR
)
5265 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5269 else if (TREE_CODE (stmt
) != BIND_EXPR
)
5270 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
5271 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5273 OMP_PARALLEL_COMBINED (stmt
) = 1;
5274 gfc_add_expr_to_block (&block
, stmt
);
5275 return gfc_finish_block (&block
);
5279 gfc_trans_omp_parallel_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
5280 gfc_omp_clauses
*clausesa
)
5283 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5284 tree stmt
, omp_clauses
= NULL_TREE
;
5287 gfc_start_block (&block
);
5289 gfc_init_block (&block
);
5291 if (clausesa
== NULL
)
5293 clausesa
= clausesa_buf
;
5294 gfc_split_omp_clauses (code
, clausesa
);
5298 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5302 stmt
= gfc_trans_omp_do_simd (code
, pblock
, clausesa
, omp_clauses
);
5305 if (TREE_CODE (stmt
) != BIND_EXPR
)
5306 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5310 else if (TREE_CODE (stmt
) != BIND_EXPR
)
5311 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
5314 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5316 OMP_PARALLEL_COMBINED (stmt
) = 1;
5318 gfc_add_expr_to_block (&block
, stmt
);
5319 return gfc_finish_block (&block
);
5323 gfc_trans_omp_parallel_sections (gfc_code
*code
)
5326 gfc_omp_clauses section_clauses
;
5327 tree stmt
, omp_clauses
;
5329 memset (§ion_clauses
, 0, sizeof (section_clauses
));
5330 section_clauses
.nowait
= true;
5332 gfc_start_block (&block
);
5333 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5336 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
5337 if (TREE_CODE (stmt
) != BIND_EXPR
)
5338 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5341 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5343 OMP_PARALLEL_COMBINED (stmt
) = 1;
5344 gfc_add_expr_to_block (&block
, stmt
);
5345 return gfc_finish_block (&block
);
5349 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
5352 gfc_omp_clauses workshare_clauses
;
5353 tree stmt
, omp_clauses
;
5355 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
5356 workshare_clauses
.nowait
= true;
5358 gfc_start_block (&block
);
5359 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5362 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
5363 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5364 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5366 OMP_PARALLEL_COMBINED (stmt
) = 1;
5367 gfc_add_expr_to_block (&block
, stmt
);
5368 return gfc_finish_block (&block
);
5372 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5374 stmtblock_t block
, body
;
5375 tree omp_clauses
, stmt
;
5376 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
5378 gfc_start_block (&block
);
5380 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
5382 gfc_init_block (&body
);
5383 for (code
= code
->block
; code
; code
= code
->block
)
5385 /* Last section is special because of lastprivate, so even if it
5386 is empty, chain it in. */
5387 stmt
= gfc_trans_omp_code (code
->next
,
5388 has_lastprivate
&& code
->block
== NULL
);
5389 if (! IS_EMPTY_STMT (stmt
))
5391 stmt
= build1_v (OMP_SECTION
, stmt
);
5392 gfc_add_expr_to_block (&body
, stmt
);
5395 stmt
= gfc_finish_block (&body
);
5397 stmt
= build2_loc (input_location
, OMP_SECTIONS
, void_type_node
, stmt
,
5399 gfc_add_expr_to_block (&block
, stmt
);
5401 return gfc_finish_block (&block
);
5405 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5407 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
5408 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5409 stmt
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, stmt
,
5415 gfc_trans_omp_task (gfc_code
*code
)
5418 tree stmt
, omp_clauses
;
5420 gfc_start_block (&block
);
5421 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5424 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5425 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5426 stmt
= build2_loc (input_location
, OMP_TASK
, void_type_node
, stmt
,
5428 gfc_add_expr_to_block (&block
, stmt
);
5429 return gfc_finish_block (&block
);
5433 gfc_trans_omp_taskgroup (gfc_code
*code
)
5435 tree body
= gfc_trans_code (code
->block
->next
);
5436 tree stmt
= make_node (OMP_TASKGROUP
);
5437 TREE_TYPE (stmt
) = void_type_node
;
5438 OMP_TASKGROUP_BODY (stmt
) = body
;
5439 OMP_TASKGROUP_CLAUSES (stmt
) = NULL_TREE
;
5444 gfc_trans_omp_taskwait (void)
5446 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT
);
5447 return build_call_expr_loc (input_location
, decl
, 0);
5451 gfc_trans_omp_taskyield (void)
5453 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD
);
5454 return build_call_expr_loc (input_location
, decl
, 0);
5458 gfc_trans_omp_distribute (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
5461 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5462 tree stmt
, omp_clauses
= NULL_TREE
;
5464 gfc_start_block (&block
);
5465 if (clausesa
== NULL
)
5467 clausesa
= clausesa_buf
;
5468 gfc_split_omp_clauses (code
, clausesa
);
5472 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
5476 case EXEC_OMP_DISTRIBUTE
:
5477 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5478 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5479 /* This is handled in gfc_trans_omp_do. */
5482 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5483 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5484 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5485 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
5486 if (TREE_CODE (stmt
) != BIND_EXPR
)
5487 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5491 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5492 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5493 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5494 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
5495 if (TREE_CODE (stmt
) != BIND_EXPR
)
5496 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5500 case EXEC_OMP_DISTRIBUTE_SIMD
:
5501 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5502 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5503 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5504 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5505 if (TREE_CODE (stmt
) != BIND_EXPR
)
5506 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5515 tree distribute
= make_node (OMP_DISTRIBUTE
);
5516 TREE_TYPE (distribute
) = void_type_node
;
5517 OMP_FOR_BODY (distribute
) = stmt
;
5518 OMP_FOR_CLAUSES (distribute
) = omp_clauses
;
5521 gfc_add_expr_to_block (&block
, stmt
);
5522 return gfc_finish_block (&block
);
5526 gfc_trans_omp_teams (gfc_code
*code
, gfc_omp_clauses
*clausesa
,
5530 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
5532 bool combined
= true;
5534 gfc_start_block (&block
);
5535 if (clausesa
== NULL
)
5537 clausesa
= clausesa_buf
;
5538 gfc_split_omp_clauses (code
, clausesa
);
5543 = chainon (omp_clauses
,
5544 gfc_trans_omp_clauses (&block
,
5545 &clausesa
[GFC_OMP_SPLIT_TEAMS
],
5551 case EXEC_OMP_TARGET_TEAMS
:
5552 case EXEC_OMP_TEAMS
:
5553 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5556 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5557 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5558 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DISTRIBUTE
, NULL
,
5559 &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
5563 stmt
= gfc_trans_omp_distribute (code
, clausesa
);
5568 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5569 stmt
= build2_loc (input_location
, OMP_TEAMS
, void_type_node
, stmt
,
5572 OMP_TEAMS_COMBINED (stmt
) = 1;
5574 gfc_add_expr_to_block (&block
, stmt
);
5575 return gfc_finish_block (&block
);
5579 gfc_trans_omp_target (gfc_code
*code
)
5582 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
5583 tree stmt
, omp_clauses
= NULL_TREE
;
5585 gfc_start_block (&block
);
5586 gfc_split_omp_clauses (code
, clausesa
);
5589 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TARGET
],
5593 case EXEC_OMP_TARGET
:
5595 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5596 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5598 case EXEC_OMP_TARGET_PARALLEL
:
5603 gfc_start_block (&iblock
);
5605 = gfc_trans_omp_clauses (&iblock
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
5607 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5608 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
5610 gfc_add_expr_to_block (&iblock
, stmt
);
5611 stmt
= gfc_finish_block (&iblock
);
5612 if (TREE_CODE (stmt
) != BIND_EXPR
)
5613 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5618 case EXEC_OMP_TARGET_PARALLEL_DO
:
5619 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
5620 if (TREE_CODE (stmt
) != BIND_EXPR
)
5621 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5625 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5626 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
5627 if (TREE_CODE (stmt
) != BIND_EXPR
)
5628 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5632 case EXEC_OMP_TARGET_SIMD
:
5633 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5634 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5635 if (TREE_CODE (stmt
) != BIND_EXPR
)
5636 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5642 && (clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
5643 || clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
))
5645 gfc_omp_clauses clausesb
;
5647 /* For combined !$omp target teams, the num_teams and
5648 thread_limit clauses are evaluated before entering the
5649 target construct. */
5650 memset (&clausesb
, '\0', sizeof (clausesb
));
5651 clausesb
.num_teams
= clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
;
5652 clausesb
.thread_limit
= clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
;
5653 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
= NULL
;
5654 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
= NULL
;
5656 = gfc_trans_omp_clauses (&block
, &clausesb
, code
->loc
);
5658 stmt
= gfc_trans_omp_teams (code
, clausesa
, teams_clauses
);
5663 stmt
= gfc_trans_omp_teams (code
, clausesa
, NULL_TREE
);
5665 if (TREE_CODE (stmt
) != BIND_EXPR
)
5666 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5673 stmt
= build2_loc (input_location
, OMP_TARGET
, void_type_node
, stmt
,
5675 if (code
->op
!= EXEC_OMP_TARGET
)
5676 OMP_TARGET_COMBINED (stmt
) = 1;
5677 cfun
->has_omp_target
= true;
5679 gfc_add_expr_to_block (&block
, stmt
);
5680 return gfc_finish_block (&block
);
5684 gfc_trans_omp_taskloop (gfc_code
*code
)
5687 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
5688 tree stmt
, omp_clauses
= NULL_TREE
;
5690 gfc_start_block (&block
);
5691 gfc_split_omp_clauses (code
, clausesa
);
5694 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TASKLOOP
],
5698 case EXEC_OMP_TASKLOOP
:
5699 /* This is handled in gfc_trans_omp_do. */
5702 case EXEC_OMP_TASKLOOP_SIMD
:
5703 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
5704 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
5705 if (TREE_CODE (stmt
) != BIND_EXPR
)
5706 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
5715 tree taskloop
= make_node (OMP_TASKLOOP
);
5716 TREE_TYPE (taskloop
) = void_type_node
;
5717 OMP_FOR_BODY (taskloop
) = stmt
;
5718 OMP_FOR_CLAUSES (taskloop
) = omp_clauses
;
5721 gfc_add_expr_to_block (&block
, stmt
);
5722 return gfc_finish_block (&block
);
5726 gfc_trans_omp_target_data (gfc_code
*code
)
5729 tree stmt
, omp_clauses
;
5731 gfc_start_block (&block
);
5732 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5734 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5735 stmt
= build2_loc (input_location
, OMP_TARGET_DATA
, void_type_node
, stmt
,
5737 gfc_add_expr_to_block (&block
, stmt
);
5738 return gfc_finish_block (&block
);
5742 gfc_trans_omp_target_enter_data (gfc_code
*code
)
5745 tree stmt
, omp_clauses
;
5747 gfc_start_block (&block
);
5748 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5750 stmt
= build1_loc (input_location
, OMP_TARGET_ENTER_DATA
, void_type_node
,
5752 gfc_add_expr_to_block (&block
, stmt
);
5753 return gfc_finish_block (&block
);
5757 gfc_trans_omp_target_exit_data (gfc_code
*code
)
5760 tree stmt
, omp_clauses
;
5762 gfc_start_block (&block
);
5763 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5765 stmt
= build1_loc (input_location
, OMP_TARGET_EXIT_DATA
, void_type_node
,
5767 gfc_add_expr_to_block (&block
, stmt
);
5768 return gfc_finish_block (&block
);
5772 gfc_trans_omp_target_update (gfc_code
*code
)
5775 tree stmt
, omp_clauses
;
5777 gfc_start_block (&block
);
5778 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
5780 stmt
= build1_loc (input_location
, OMP_TARGET_UPDATE
, void_type_node
,
5782 gfc_add_expr_to_block (&block
, stmt
);
5783 return gfc_finish_block (&block
);
5787 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
5789 tree res
, tmp
, stmt
;
5790 stmtblock_t block
, *pblock
= NULL
;
5791 stmtblock_t singleblock
;
5792 int saved_ompws_flags
;
5793 bool singleblock_in_progress
= false;
5794 /* True if previous gfc_code in workshare construct is not workshared. */
5795 bool prev_singleunit
;
5797 code
= code
->block
->next
;
5801 gfc_start_block (&block
);
5804 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
5805 prev_singleunit
= false;
5807 /* Translate statements one by one to trees until we reach
5808 the end of the workshare construct. Adjacent gfc_codes that
5809 are a single unit of work are clustered and encapsulated in a
5810 single OMP_SINGLE construct. */
5811 for (; code
; code
= code
->next
)
5813 if (code
->here
!= 0)
5815 res
= gfc_trans_label_here (code
);
5816 gfc_add_expr_to_block (pblock
, res
);
5819 /* No dependence analysis, use for clauses with wait.
5820 If this is the last gfc_code, use default omp_clauses. */
5821 if (code
->next
== NULL
&& clauses
->nowait
)
5822 ompws_flags
|= OMPWS_NOWAIT
;
5824 /* By default, every gfc_code is a single unit of work. */
5825 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
5826 ompws_flags
&= ~(OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
);
5835 res
= gfc_trans_assign (code
);
5838 case EXEC_POINTER_ASSIGN
:
5839 res
= gfc_trans_pointer_assign (code
);
5842 case EXEC_INIT_ASSIGN
:
5843 res
= gfc_trans_init_assign (code
);
5847 res
= gfc_trans_forall (code
);
5851 res
= gfc_trans_where (code
);
5854 case EXEC_OMP_ATOMIC
:
5855 res
= gfc_trans_omp_directive (code
);
5858 case EXEC_OMP_PARALLEL
:
5859 case EXEC_OMP_PARALLEL_DO
:
5860 case EXEC_OMP_PARALLEL_SECTIONS
:
5861 case EXEC_OMP_PARALLEL_WORKSHARE
:
5862 case EXEC_OMP_CRITICAL
:
5863 saved_ompws_flags
= ompws_flags
;
5865 res
= gfc_trans_omp_directive (code
);
5866 ompws_flags
= saved_ompws_flags
;
5870 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
5873 gfc_set_backend_locus (&code
->loc
);
5875 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
5877 if (prev_singleunit
)
5879 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5880 /* Add current gfc_code to single block. */
5881 gfc_add_expr_to_block (&singleblock
, res
);
5884 /* Finish single block and add it to pblock. */
5885 tmp
= gfc_finish_block (&singleblock
);
5886 tmp
= build2_loc (input_location
, OMP_SINGLE
,
5887 void_type_node
, tmp
, NULL_TREE
);
5888 gfc_add_expr_to_block (pblock
, tmp
);
5889 /* Add current gfc_code to pblock. */
5890 gfc_add_expr_to_block (pblock
, res
);
5891 singleblock_in_progress
= false;
5896 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
5898 /* Start single block. */
5899 gfc_init_block (&singleblock
);
5900 gfc_add_expr_to_block (&singleblock
, res
);
5901 singleblock_in_progress
= true;
5904 /* Add the new statement to the block. */
5905 gfc_add_expr_to_block (pblock
, res
);
5907 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
5911 /* Finish remaining SINGLE block, if we were in the middle of one. */
5912 if (singleblock_in_progress
)
5914 /* Finish single block and add it to pblock. */
5915 tmp
= gfc_finish_block (&singleblock
);
5916 tmp
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, tmp
,
5918 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
5920 gfc_add_expr_to_block (pblock
, tmp
);
5923 stmt
= gfc_finish_block (pblock
);
5924 if (TREE_CODE (stmt
) != BIND_EXPR
)
5926 if (!IS_EMPTY_STMT (stmt
))
5928 tree bindblock
= poplevel (1, 0);
5929 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
5937 if (IS_EMPTY_STMT (stmt
) && !clauses
->nowait
)
5938 stmt
= gfc_trans_omp_barrier ();
5945 gfc_trans_oacc_declare (gfc_code
*code
)
5948 tree stmt
, oacc_clauses
;
5949 enum tree_code construct_code
;
5951 construct_code
= OACC_DATA
;
5953 gfc_start_block (&block
);
5955 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.oacc_declare
->clauses
,
5956 code
->loc
, false, true);
5957 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
5958 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
5960 gfc_add_expr_to_block (&block
, stmt
);
5962 return gfc_finish_block (&block
);
5966 gfc_trans_oacc_directive (gfc_code
*code
)
5970 case EXEC_OACC_PARALLEL_LOOP
:
5971 case EXEC_OACC_KERNELS_LOOP
:
5972 case EXEC_OACC_SERIAL_LOOP
:
5973 return gfc_trans_oacc_combined_directive (code
);
5974 case EXEC_OACC_PARALLEL
:
5975 case EXEC_OACC_KERNELS
:
5976 case EXEC_OACC_SERIAL
:
5977 case EXEC_OACC_DATA
:
5978 case EXEC_OACC_HOST_DATA
:
5979 return gfc_trans_oacc_construct (code
);
5980 case EXEC_OACC_LOOP
:
5981 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
5983 case EXEC_OACC_UPDATE
:
5984 case EXEC_OACC_CACHE
:
5985 case EXEC_OACC_ENTER_DATA
:
5986 case EXEC_OACC_EXIT_DATA
:
5987 return gfc_trans_oacc_executable_directive (code
);
5988 case EXEC_OACC_WAIT
:
5989 return gfc_trans_oacc_wait_directive (code
);
5990 case EXEC_OACC_ATOMIC
:
5991 return gfc_trans_omp_atomic (code
);
5992 case EXEC_OACC_DECLARE
:
5993 return gfc_trans_oacc_declare (code
);
6000 gfc_trans_omp_directive (gfc_code
*code
)
6004 case EXEC_OMP_ATOMIC
:
6005 return gfc_trans_omp_atomic (code
);
6006 case EXEC_OMP_BARRIER
:
6007 return gfc_trans_omp_barrier ();
6008 case EXEC_OMP_CANCEL
:
6009 return gfc_trans_omp_cancel (code
);
6010 case EXEC_OMP_CANCELLATION_POINT
:
6011 return gfc_trans_omp_cancellation_point (code
);
6012 case EXEC_OMP_CRITICAL
:
6013 return gfc_trans_omp_critical (code
);
6014 case EXEC_OMP_DISTRIBUTE
:
6017 case EXEC_OMP_TASKLOOP
:
6018 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
6020 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
6021 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6022 case EXEC_OMP_DISTRIBUTE_SIMD
:
6023 return gfc_trans_omp_distribute (code
, NULL
);
6024 case EXEC_OMP_DO_SIMD
:
6025 return gfc_trans_omp_do_simd (code
, NULL
, NULL
, NULL_TREE
);
6026 case EXEC_OMP_FLUSH
:
6027 return gfc_trans_omp_flush ();
6028 case EXEC_OMP_MASTER
:
6029 return gfc_trans_omp_master (code
);
6030 case EXEC_OMP_ORDERED
:
6031 return gfc_trans_omp_ordered (code
);
6032 case EXEC_OMP_PARALLEL
:
6033 return gfc_trans_omp_parallel (code
);
6034 case EXEC_OMP_PARALLEL_DO
:
6035 return gfc_trans_omp_parallel_do (code
, NULL
, NULL
);
6036 case EXEC_OMP_PARALLEL_DO_SIMD
:
6037 return gfc_trans_omp_parallel_do_simd (code
, NULL
, NULL
);
6038 case EXEC_OMP_PARALLEL_SECTIONS
:
6039 return gfc_trans_omp_parallel_sections (code
);
6040 case EXEC_OMP_PARALLEL_WORKSHARE
:
6041 return gfc_trans_omp_parallel_workshare (code
);
6042 case EXEC_OMP_SECTIONS
:
6043 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
6044 case EXEC_OMP_SINGLE
:
6045 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
6046 case EXEC_OMP_TARGET
:
6047 case EXEC_OMP_TARGET_PARALLEL
:
6048 case EXEC_OMP_TARGET_PARALLEL_DO
:
6049 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
6050 case EXEC_OMP_TARGET_SIMD
:
6051 case EXEC_OMP_TARGET_TEAMS
:
6052 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6053 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6054 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6055 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6056 return gfc_trans_omp_target (code
);
6057 case EXEC_OMP_TARGET_DATA
:
6058 return gfc_trans_omp_target_data (code
);
6059 case EXEC_OMP_TARGET_ENTER_DATA
:
6060 return gfc_trans_omp_target_enter_data (code
);
6061 case EXEC_OMP_TARGET_EXIT_DATA
:
6062 return gfc_trans_omp_target_exit_data (code
);
6063 case EXEC_OMP_TARGET_UPDATE
:
6064 return gfc_trans_omp_target_update (code
);
6066 return gfc_trans_omp_task (code
);
6067 case EXEC_OMP_TASKGROUP
:
6068 return gfc_trans_omp_taskgroup (code
);
6069 case EXEC_OMP_TASKLOOP_SIMD
:
6070 return gfc_trans_omp_taskloop (code
);
6071 case EXEC_OMP_TASKWAIT
:
6072 return gfc_trans_omp_taskwait ();
6073 case EXEC_OMP_TASKYIELD
:
6074 return gfc_trans_omp_taskyield ();
6075 case EXEC_OMP_TEAMS
:
6076 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6077 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6078 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6079 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
6080 return gfc_trans_omp_teams (code
, NULL
, NULL_TREE
);
6081 case EXEC_OMP_WORKSHARE
:
6082 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);
6089 gfc_trans_omp_declare_simd (gfc_namespace
*ns
)
6094 gfc_omp_declare_simd
*ods
;
6095 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
6097 tree c
= gfc_trans_omp_clauses (NULL
, ods
->clauses
, ods
->where
, true);
6098 tree fndecl
= ns
->proc_name
->backend_decl
;
6100 c
= tree_cons (NULL_TREE
, c
, NULL_TREE
);
6101 c
= build_tree_list (get_identifier ("omp declare simd"), c
);
6102 TREE_CHAIN (c
) = DECL_ATTRIBUTES (fndecl
);
6103 DECL_ATTRIBUTES (fndecl
) = c
;