1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005-2016 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"
39 #include "gomp-constants.h"
43 /* True if OpenMP should privatize what this DECL points to rather
44 than the DECL itself. */
47 gfc_omp_privatize_by_reference (const_tree decl
)
49 tree type
= TREE_TYPE (decl
);
51 if (TREE_CODE (type
) == REFERENCE_TYPE
52 && (!DECL_ARTIFICIAL (decl
) || TREE_CODE (decl
) == PARM_DECL
))
55 if (TREE_CODE (type
) == POINTER_TYPE
)
57 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
58 that have POINTER_TYPE type and aren't scalar pointers, scalar
59 allocatables, Cray pointees or C pointers are supposed to be
60 privatized by reference. */
61 if (GFC_DECL_GET_SCALAR_POINTER (decl
)
62 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
63 || GFC_DECL_CRAY_POINTEE (decl
)
64 || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
67 if (!DECL_ARTIFICIAL (decl
)
68 && TREE_CODE (TREE_TYPE (type
)) != FUNCTION_TYPE
)
71 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
73 if (DECL_LANG_SPECIFIC (decl
)
74 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
81 /* True if OpenMP sharing attribute of DECL is predetermined. */
83 enum omp_clause_default_kind
84 gfc_omp_predetermined_sharing (tree decl
)
86 /* Associate names preserve the association established during ASSOCIATE.
87 As they are implemented either as pointers to the selector or array
88 descriptor and shouldn't really change in the ASSOCIATE region,
89 this decl can be either shared or firstprivate. If it is a pointer,
90 use firstprivate, as it is cheaper that way, otherwise make it shared. */
91 if (GFC_DECL_ASSOCIATE_VAR_P (decl
))
93 if (TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
94 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
96 return OMP_CLAUSE_DEFAULT_SHARED
;
99 if (DECL_ARTIFICIAL (decl
)
100 && ! GFC_DECL_RESULT (decl
)
101 && ! (DECL_LANG_SPECIFIC (decl
)
102 && GFC_DECL_SAVED_DESCRIPTOR (decl
)))
103 return OMP_CLAUSE_DEFAULT_SHARED
;
105 /* Cray pointees shouldn't be listed in any clauses and should be
106 gimplified to dereference of the corresponding Cray pointer.
107 Make them all private, so that they are emitted in the debug
109 if (GFC_DECL_CRAY_POINTEE (decl
))
110 return OMP_CLAUSE_DEFAULT_PRIVATE
;
112 /* Assumed-size arrays are predetermined shared. */
113 if (TREE_CODE (decl
) == PARM_DECL
114 && GFC_ARRAY_TYPE_P (TREE_TYPE (decl
))
115 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl
)) == GFC_ARRAY_UNKNOWN
116 && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl
),
117 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)) - 1)
119 return OMP_CLAUSE_DEFAULT_SHARED
;
121 /* Dummy procedures aren't considered variables by OpenMP, thus are
122 disallowed in OpenMP clauses. They are represented as PARM_DECLs
123 in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
124 to avoid complaining about their uses with default(none). */
125 if (TREE_CODE (decl
) == PARM_DECL
126 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
127 && TREE_CODE (TREE_TYPE (TREE_TYPE (decl
))) == FUNCTION_TYPE
)
128 return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
130 /* COMMON and EQUIVALENCE decls are shared. They
131 are only referenced through DECL_VALUE_EXPR of the variables
132 contained in them. If those are privatized, they will not be
133 gimplified to the COMMON or EQUIVALENCE decls. */
134 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
135 return OMP_CLAUSE_DEFAULT_SHARED
;
137 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
138 return OMP_CLAUSE_DEFAULT_SHARED
;
140 /* These are either array or derived parameters, or vtables.
141 In the former cases, the OpenMP standard doesn't consider them to be
142 variables at all (they can't be redefined), but they can nevertheless appear
143 in parallel/task regions and for default(none) purposes treat them as shared.
144 For vtables likely the same handling is desirable. */
145 if (TREE_CODE (decl
) == VAR_DECL
146 && TREE_READONLY (decl
)
147 && TREE_STATIC (decl
))
148 return OMP_CLAUSE_DEFAULT_SHARED
;
150 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
153 /* Return decl that should be used when reporting DEFAULT(NONE)
157 gfc_omp_report_decl (tree decl
)
159 if (DECL_ARTIFICIAL (decl
)
160 && DECL_LANG_SPECIFIC (decl
)
161 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
162 return GFC_DECL_SAVED_DESCRIPTOR (decl
);
167 /* Return true if TYPE has any allocatable components. */
170 gfc_has_alloc_comps (tree type
, tree decl
)
174 if (POINTER_TYPE_P (type
))
176 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
177 type
= TREE_TYPE (type
);
178 else if (GFC_DECL_GET_SCALAR_POINTER (decl
))
182 if (GFC_DESCRIPTOR_TYPE_P (type
) || GFC_ARRAY_TYPE_P (type
))
183 type
= gfc_get_element_type (type
);
185 if (TREE_CODE (type
) != RECORD_TYPE
)
188 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
190 ftype
= TREE_TYPE (field
);
191 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
193 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
194 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
196 if (gfc_has_alloc_comps (ftype
, field
))
202 /* Return true if DECL in private clause needs
203 OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
205 gfc_omp_private_outer_ref (tree decl
)
207 tree type
= TREE_TYPE (decl
);
209 if (GFC_DESCRIPTOR_TYPE_P (type
)
210 && GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_ALLOCATABLE
)
213 if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
))
216 if (gfc_omp_privatize_by_reference (decl
))
217 type
= TREE_TYPE (type
);
219 if (gfc_has_alloc_comps (type
, decl
))
225 /* Callback for gfc_omp_unshare_expr. */
228 gfc_omp_unshare_expr_r (tree
*tp
, int *walk_subtrees
, void *)
231 enum tree_code code
= TREE_CODE (t
);
233 /* Stop at types, decls, constants like copy_tree_r. */
234 if (TREE_CODE_CLASS (code
) == tcc_type
235 || TREE_CODE_CLASS (code
) == tcc_declaration
236 || TREE_CODE_CLASS (code
) == tcc_constant
239 else if (handled_component_p (t
)
240 || TREE_CODE (t
) == MEM_REF
)
242 *tp
= unshare_expr (t
);
249 /* Unshare in expr anything that the FE which normally doesn't
250 care much about tree sharing (because during gimplification
251 everything is unshared) could cause problems with tree sharing
252 at omp-low.c time. */
255 gfc_omp_unshare_expr (tree expr
)
257 walk_tree (&expr
, gfc_omp_unshare_expr_r
, NULL
, NULL
);
261 enum walk_alloc_comps
263 WALK_ALLOC_COMPS_DTOR
,
264 WALK_ALLOC_COMPS_DEFAULT_CTOR
,
265 WALK_ALLOC_COMPS_COPY_CTOR
268 /* Handle allocatable components in OpenMP clauses. */
271 gfc_walk_alloc_comps (tree decl
, tree dest
, tree var
,
272 enum walk_alloc_comps kind
)
274 stmtblock_t block
, tmpblock
;
275 tree type
= TREE_TYPE (decl
), then_b
, tem
, field
;
276 gfc_init_block (&block
);
278 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
280 if (GFC_DESCRIPTOR_TYPE_P (type
))
282 gfc_init_block (&tmpblock
);
283 tem
= gfc_full_array_size (&tmpblock
, decl
,
284 GFC_TYPE_ARRAY_RANK (type
));
285 then_b
= gfc_finish_block (&tmpblock
);
286 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (then_b
));
287 tem
= gfc_omp_unshare_expr (tem
);
288 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
289 gfc_array_index_type
, tem
,
294 if (!TYPE_DOMAIN (type
)
295 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
296 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
297 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
299 tem
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
300 TYPE_SIZE_UNIT (type
),
301 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
302 tem
= size_binop (MINUS_EXPR
, tem
, size_one_node
);
305 tem
= array_type_nelts (type
);
306 tem
= fold_convert (gfc_array_index_type
, tem
);
309 tree nelems
= gfc_evaluate_now (tem
, &block
);
310 tree index
= gfc_create_var (gfc_array_index_type
, "S");
312 gfc_init_block (&tmpblock
);
313 tem
= gfc_conv_array_data (decl
);
314 tree declvar
= build_fold_indirect_ref_loc (input_location
, tem
);
315 tree declvref
= gfc_build_array_ref (declvar
, index
, NULL
);
316 tree destvar
, destvref
= NULL_TREE
;
319 tem
= gfc_conv_array_data (dest
);
320 destvar
= build_fold_indirect_ref_loc (input_location
, tem
);
321 destvref
= gfc_build_array_ref (destvar
, index
, NULL
);
323 gfc_add_expr_to_block (&tmpblock
,
324 gfc_walk_alloc_comps (declvref
, destvref
,
328 gfc_init_loopinfo (&loop
);
330 loop
.from
[0] = gfc_index_zero_node
;
331 loop
.loopvar
[0] = index
;
333 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
334 gfc_add_block_to_block (&block
, &loop
.pre
);
335 return gfc_finish_block (&block
);
337 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var
))
339 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
341 dest
= build_fold_indirect_ref_loc (input_location
, dest
);
342 type
= TREE_TYPE (decl
);
345 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
346 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
348 tree ftype
= TREE_TYPE (field
);
349 tree declf
, destf
= NULL_TREE
;
350 bool has_alloc_comps
= gfc_has_alloc_comps (ftype
, field
);
351 if ((!GFC_DESCRIPTOR_TYPE_P (ftype
)
352 || GFC_TYPE_ARRAY_AKIND (ftype
) != GFC_ARRAY_ALLOCATABLE
)
353 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field
)
356 declf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
357 decl
, field
, NULL_TREE
);
359 destf
= fold_build3_loc (input_location
, COMPONENT_REF
, ftype
,
360 dest
, field
, NULL_TREE
);
365 case WALK_ALLOC_COMPS_DTOR
:
367 case WALK_ALLOC_COMPS_DEFAULT_CTOR
:
368 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
369 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
371 gfc_add_modify (&block
, unshare_expr (destf
),
372 unshare_expr (declf
));
373 tem
= gfc_duplicate_allocatable_nocopy
374 (destf
, declf
, ftype
,
375 GFC_TYPE_ARRAY_RANK (ftype
));
377 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
378 tem
= gfc_duplicate_allocatable_nocopy (destf
, declf
, ftype
, 0);
380 case WALK_ALLOC_COMPS_COPY_CTOR
:
381 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
382 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
383 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
,
384 GFC_TYPE_ARRAY_RANK (ftype
),
386 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
387 tem
= gfc_duplicate_allocatable (destf
, declf
, ftype
, 0,
392 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
395 gfc_init_block (&tmpblock
);
396 gfc_add_expr_to_block (&tmpblock
,
397 gfc_walk_alloc_comps (declf
, destf
,
399 then_b
= gfc_finish_block (&tmpblock
);
400 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
401 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
402 tem
= gfc_conv_descriptor_data_get (unshare_expr (declf
));
403 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
404 tem
= unshare_expr (declf
);
409 tem
= fold_convert (pvoid_type_node
, tem
);
410 tem
= fold_build2_loc (input_location
, NE_EXPR
,
411 boolean_type_node
, tem
,
413 then_b
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
415 build_empty_stmt (input_location
));
417 gfc_add_expr_to_block (&block
, then_b
);
419 if (kind
== WALK_ALLOC_COMPS_DTOR
)
421 if (GFC_DESCRIPTOR_TYPE_P (ftype
)
422 && GFC_TYPE_ARRAY_AKIND (ftype
) == GFC_ARRAY_ALLOCATABLE
)
424 tem
= gfc_trans_dealloc_allocated (unshare_expr (declf
),
426 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
428 else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field
))
430 tem
= gfc_call_free (unshare_expr (declf
));
431 gfc_add_expr_to_block (&block
, gfc_omp_unshare_expr (tem
));
436 return gfc_finish_block (&block
);
439 /* Return code to initialize DECL with its default constructor, or
440 NULL if there's nothing to do. */
443 gfc_omp_clause_default_ctor (tree clause
, tree decl
, tree outer
)
445 tree type
= TREE_TYPE (decl
), size
, ptr
, cond
, then_b
, else_b
;
446 stmtblock_t block
, cond_block
;
448 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_PRIVATE
449 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LASTPRIVATE
450 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
451 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_REDUCTION
);
453 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
454 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
455 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
)))
457 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
460 gfc_start_block (&block
);
461 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
462 OMP_CLAUSE_DECL (clause
),
463 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
464 gfc_add_expr_to_block (&block
, tem
);
465 return gfc_finish_block (&block
);
470 gcc_assert (outer
!= NULL_TREE
);
472 /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
473 "not currently allocated" allocation status if outer
474 array is "not currently allocated", otherwise should be allocated. */
475 gfc_start_block (&block
);
477 gfc_init_block (&cond_block
);
479 if (GFC_DESCRIPTOR_TYPE_P (type
))
481 gfc_add_modify (&cond_block
, decl
, outer
);
482 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
483 size
= gfc_conv_descriptor_ubound_get (decl
, rank
);
484 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
486 gfc_conv_descriptor_lbound_get (decl
, rank
));
487 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
488 size
, gfc_index_one_node
);
489 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
490 size
= fold_build2_loc (input_location
, MULT_EXPR
,
491 gfc_array_index_type
, size
,
492 gfc_conv_descriptor_stride_get (decl
, rank
));
493 tree esize
= fold_convert (gfc_array_index_type
,
494 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
495 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
497 size
= unshare_expr (size
);
498 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
502 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
503 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
504 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
505 if (GFC_DESCRIPTOR_TYPE_P (type
))
506 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
), ptr
);
508 gfc_add_modify (&cond_block
, unshare_expr (decl
),
509 fold_convert (TREE_TYPE (decl
), ptr
));
510 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
512 tree tem
= gfc_walk_alloc_comps (outer
, decl
,
513 OMP_CLAUSE_DECL (clause
),
514 WALK_ALLOC_COMPS_DEFAULT_CTOR
);
515 gfc_add_expr_to_block (&cond_block
, tem
);
517 then_b
= gfc_finish_block (&cond_block
);
519 /* Reduction clause requires allocated ALLOCATABLE. */
520 if (OMP_CLAUSE_CODE (clause
) != OMP_CLAUSE_REDUCTION
)
522 gfc_init_block (&cond_block
);
523 if (GFC_DESCRIPTOR_TYPE_P (type
))
524 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (decl
),
527 gfc_add_modify (&cond_block
, unshare_expr (decl
),
528 build_zero_cst (TREE_TYPE (decl
)));
529 else_b
= gfc_finish_block (&cond_block
);
531 tree tem
= fold_convert (pvoid_type_node
,
532 GFC_DESCRIPTOR_TYPE_P (type
)
533 ? gfc_conv_descriptor_data_get (outer
) : outer
);
534 tem
= unshare_expr (tem
);
535 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
536 tem
, null_pointer_node
);
537 gfc_add_expr_to_block (&block
,
538 build3_loc (input_location
, COND_EXPR
,
539 void_type_node
, cond
, then_b
,
543 gfc_add_expr_to_block (&block
, then_b
);
545 return gfc_finish_block (&block
);
548 /* Build and return code for a copy constructor from SRC to DEST. */
551 gfc_omp_clause_copy_ctor (tree clause
, tree dest
, tree src
)
553 tree type
= TREE_TYPE (dest
), ptr
, size
, call
;
554 tree cond
, then_b
, else_b
;
555 stmtblock_t block
, cond_block
;
557 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_FIRSTPRIVATE
558 || OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
560 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
561 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
562 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
)))
564 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
566 gfc_start_block (&block
);
567 gfc_add_modify (&block
, dest
, src
);
568 tree tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
569 WALK_ALLOC_COMPS_COPY_CTOR
);
570 gfc_add_expr_to_block (&block
, tem
);
571 return gfc_finish_block (&block
);
574 return build2_v (MODIFY_EXPR
, dest
, src
);
577 /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
578 and copied from SRC. */
579 gfc_start_block (&block
);
581 gfc_init_block (&cond_block
);
583 gfc_add_modify (&cond_block
, dest
, src
);
584 if (GFC_DESCRIPTOR_TYPE_P (type
))
586 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
587 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
588 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
590 gfc_conv_descriptor_lbound_get (dest
, rank
));
591 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
592 size
, gfc_index_one_node
);
593 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
594 size
= fold_build2_loc (input_location
, MULT_EXPR
,
595 gfc_array_index_type
, size
,
596 gfc_conv_descriptor_stride_get (dest
, rank
));
597 tree esize
= fold_convert (gfc_array_index_type
,
598 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
599 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
601 size
= unshare_expr (size
);
602 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
606 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
607 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
608 gfc_allocate_using_malloc (&cond_block
, ptr
, size
, NULL_TREE
);
609 if (GFC_DESCRIPTOR_TYPE_P (type
))
610 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
), ptr
);
612 gfc_add_modify (&cond_block
, unshare_expr (dest
),
613 fold_convert (TREE_TYPE (dest
), ptr
));
615 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
616 ? gfc_conv_descriptor_data_get (src
) : src
;
617 srcptr
= unshare_expr (srcptr
);
618 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
619 call
= build_call_expr_loc (input_location
,
620 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
622 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
623 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
625 tree tem
= gfc_walk_alloc_comps (src
, dest
,
626 OMP_CLAUSE_DECL (clause
),
627 WALK_ALLOC_COMPS_COPY_CTOR
);
628 gfc_add_expr_to_block (&cond_block
, tem
);
630 then_b
= gfc_finish_block (&cond_block
);
632 gfc_init_block (&cond_block
);
633 if (GFC_DESCRIPTOR_TYPE_P (type
))
634 gfc_conv_descriptor_data_set (&cond_block
, unshare_expr (dest
),
637 gfc_add_modify (&cond_block
, unshare_expr (dest
),
638 build_zero_cst (TREE_TYPE (dest
)));
639 else_b
= gfc_finish_block (&cond_block
);
641 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
642 unshare_expr (srcptr
), null_pointer_node
);
643 gfc_add_expr_to_block (&block
,
644 build3_loc (input_location
, COND_EXPR
,
645 void_type_node
, cond
, then_b
, else_b
));
647 return gfc_finish_block (&block
);
650 /* Similarly, except use an intrinsic or pointer assignment operator
654 gfc_omp_clause_assign_op (tree clause
, tree dest
, tree src
)
656 tree type
= TREE_TYPE (dest
), ptr
, size
, call
, nonalloc
;
657 tree cond
, then_b
, else_b
;
658 stmtblock_t block
, cond_block
, cond_block2
, inner_block
;
660 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
661 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
662 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
)))
664 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
666 gfc_start_block (&block
);
667 /* First dealloc any allocatable components in DEST. */
668 tree tem
= gfc_walk_alloc_comps (dest
, NULL_TREE
,
669 OMP_CLAUSE_DECL (clause
),
670 WALK_ALLOC_COMPS_DTOR
);
671 gfc_add_expr_to_block (&block
, tem
);
672 /* Then copy over toplevel data. */
673 gfc_add_modify (&block
, dest
, src
);
674 /* Finally allocate any allocatable components and copy. */
675 tem
= gfc_walk_alloc_comps (src
, dest
, OMP_CLAUSE_DECL (clause
),
676 WALK_ALLOC_COMPS_COPY_CTOR
);
677 gfc_add_expr_to_block (&block
, tem
);
678 return gfc_finish_block (&block
);
681 return build2_v (MODIFY_EXPR
, dest
, src
);
684 gfc_start_block (&block
);
686 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
688 then_b
= gfc_walk_alloc_comps (dest
, NULL_TREE
, OMP_CLAUSE_DECL (clause
),
689 WALK_ALLOC_COMPS_DTOR
);
690 tree tem
= fold_convert (pvoid_type_node
,
691 GFC_DESCRIPTOR_TYPE_P (type
)
692 ? gfc_conv_descriptor_data_get (dest
) : dest
);
693 tem
= unshare_expr (tem
);
694 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
695 tem
, null_pointer_node
);
696 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
697 then_b
, build_empty_stmt (input_location
));
698 gfc_add_expr_to_block (&block
, tem
);
701 gfc_init_block (&cond_block
);
703 if (GFC_DESCRIPTOR_TYPE_P (type
))
705 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
706 size
= gfc_conv_descriptor_ubound_get (src
, rank
);
707 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
709 gfc_conv_descriptor_lbound_get (src
, rank
));
710 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
711 size
, gfc_index_one_node
);
712 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
713 size
= fold_build2_loc (input_location
, MULT_EXPR
,
714 gfc_array_index_type
, size
,
715 gfc_conv_descriptor_stride_get (src
, rank
));
716 tree esize
= fold_convert (gfc_array_index_type
,
717 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
718 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
720 size
= unshare_expr (size
);
721 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
725 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
726 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
728 tree destptr
= GFC_DESCRIPTOR_TYPE_P (type
)
729 ? gfc_conv_descriptor_data_get (dest
) : dest
;
730 destptr
= unshare_expr (destptr
);
731 destptr
= fold_convert (pvoid_type_node
, destptr
);
732 gfc_add_modify (&cond_block
, ptr
, destptr
);
734 nonalloc
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
735 destptr
, null_pointer_node
);
737 if (GFC_DESCRIPTOR_TYPE_P (type
))
740 for (i
= 0; i
< GFC_TYPE_ARRAY_RANK (type
); i
++)
742 tree rank
= gfc_rank_cst
[i
];
743 tree tem
= gfc_conv_descriptor_ubound_get (src
, rank
);
744 tem
= fold_build2_loc (input_location
, MINUS_EXPR
,
745 gfc_array_index_type
, tem
,
746 gfc_conv_descriptor_lbound_get (src
, rank
));
747 tem
= fold_build2_loc (input_location
, PLUS_EXPR
,
748 gfc_array_index_type
, tem
,
749 gfc_conv_descriptor_lbound_get (dest
, rank
));
750 tem
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
751 tem
, gfc_conv_descriptor_ubound_get (dest
,
753 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
754 boolean_type_node
, cond
, tem
);
758 gfc_init_block (&cond_block2
);
760 if (GFC_DESCRIPTOR_TYPE_P (type
))
762 gfc_init_block (&inner_block
);
763 gfc_allocate_using_malloc (&inner_block
, ptr
, size
, NULL_TREE
);
764 then_b
= gfc_finish_block (&inner_block
);
766 gfc_init_block (&inner_block
);
767 gfc_add_modify (&inner_block
, ptr
,
768 gfc_call_realloc (&inner_block
, ptr
, size
));
769 else_b
= gfc_finish_block (&inner_block
);
771 gfc_add_expr_to_block (&cond_block2
,
772 build3_loc (input_location
, COND_EXPR
,
774 unshare_expr (nonalloc
),
776 gfc_add_modify (&cond_block2
, dest
, src
);
777 gfc_conv_descriptor_data_set (&cond_block2
, unshare_expr (dest
), ptr
);
781 gfc_allocate_using_malloc (&cond_block2
, ptr
, size
, NULL_TREE
);
782 gfc_add_modify (&cond_block2
, unshare_expr (dest
),
783 fold_convert (type
, ptr
));
785 then_b
= gfc_finish_block (&cond_block2
);
786 else_b
= build_empty_stmt (input_location
);
788 gfc_add_expr_to_block (&cond_block
,
789 build3_loc (input_location
, COND_EXPR
,
790 void_type_node
, unshare_expr (cond
),
793 tree srcptr
= GFC_DESCRIPTOR_TYPE_P (type
)
794 ? gfc_conv_descriptor_data_get (src
) : src
;
795 srcptr
= unshare_expr (srcptr
);
796 srcptr
= fold_convert (pvoid_type_node
, srcptr
);
797 call
= build_call_expr_loc (input_location
,
798 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, ptr
,
800 gfc_add_expr_to_block (&cond_block
, fold_convert (void_type_node
, call
));
801 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
803 tree tem
= gfc_walk_alloc_comps (src
, dest
,
804 OMP_CLAUSE_DECL (clause
),
805 WALK_ALLOC_COMPS_COPY_CTOR
);
806 gfc_add_expr_to_block (&cond_block
, tem
);
808 then_b
= gfc_finish_block (&cond_block
);
810 if (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_COPYIN
)
812 gfc_init_block (&cond_block
);
813 if (GFC_DESCRIPTOR_TYPE_P (type
))
814 gfc_add_expr_to_block (&cond_block
,
815 gfc_trans_dealloc_allocated (unshare_expr (dest
),
819 destptr
= gfc_evaluate_now (destptr
, &cond_block
);
820 gfc_add_expr_to_block (&cond_block
, gfc_call_free (destptr
));
821 gfc_add_modify (&cond_block
, unshare_expr (dest
),
822 build_zero_cst (TREE_TYPE (dest
)));
824 else_b
= gfc_finish_block (&cond_block
);
826 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
827 unshare_expr (srcptr
), null_pointer_node
);
828 gfc_add_expr_to_block (&block
,
829 build3_loc (input_location
, COND_EXPR
,
830 void_type_node
, cond
,
834 gfc_add_expr_to_block (&block
, then_b
);
836 return gfc_finish_block (&block
);
840 gfc_omp_linear_clause_add_loop (stmtblock_t
*block
, tree dest
, tree src
,
841 tree add
, tree nelems
)
843 stmtblock_t tmpblock
;
844 tree desta
, srca
, index
= gfc_create_var (gfc_array_index_type
, "S");
845 nelems
= gfc_evaluate_now (nelems
, block
);
847 gfc_init_block (&tmpblock
);
848 if (TREE_CODE (TREE_TYPE (dest
)) == ARRAY_TYPE
)
850 desta
= gfc_build_array_ref (dest
, index
, NULL
);
851 srca
= gfc_build_array_ref (src
, index
, NULL
);
855 gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest
)));
856 tree idx
= fold_build2 (MULT_EXPR
, sizetype
,
857 fold_convert (sizetype
, index
),
858 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest
))));
859 desta
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
860 TREE_TYPE (dest
), dest
,
862 srca
= build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR
,
863 TREE_TYPE (src
), src
,
866 gfc_add_modify (&tmpblock
, desta
,
867 fold_build2 (PLUS_EXPR
, TREE_TYPE (desta
),
871 gfc_init_loopinfo (&loop
);
873 loop
.from
[0] = gfc_index_zero_node
;
874 loop
.loopvar
[0] = index
;
876 gfc_trans_scalarizing_loops (&loop
, &tmpblock
);
877 gfc_add_block_to_block (block
, &loop
.pre
);
880 /* Build and return code for a constructor of DEST that initializes
881 it to SRC plus ADD (ADD is scalar integer). */
884 gfc_omp_clause_linear_ctor (tree clause
, tree dest
, tree src
, tree add
)
886 tree type
= TREE_TYPE (dest
), ptr
, size
, nelems
= NULL_TREE
;
889 gcc_assert (OMP_CLAUSE_CODE (clause
) == OMP_CLAUSE_LINEAR
);
891 gfc_start_block (&block
);
892 add
= gfc_evaluate_now (add
, &block
);
894 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
895 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
896 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
)))
898 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
899 if (!TYPE_DOMAIN (type
)
900 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == NULL_TREE
901 || TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
902 || TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) == error_mark_node
)
904 nelems
= fold_build2 (EXACT_DIV_EXPR
, sizetype
,
905 TYPE_SIZE_UNIT (type
),
906 TYPE_SIZE_UNIT (TREE_TYPE (type
)));
907 nelems
= size_binop (MINUS_EXPR
, nelems
, size_one_node
);
910 nelems
= array_type_nelts (type
);
911 nelems
= fold_convert (gfc_array_index_type
, nelems
);
913 gfc_omp_linear_clause_add_loop (&block
, dest
, src
, add
, nelems
);
914 return gfc_finish_block (&block
);
917 /* Allocatable arrays in LINEAR clauses need to be allocated
918 and copied from SRC. */
919 gfc_add_modify (&block
, dest
, src
);
920 if (GFC_DESCRIPTOR_TYPE_P (type
))
922 tree rank
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (type
) - 1];
923 size
= gfc_conv_descriptor_ubound_get (dest
, rank
);
924 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
926 gfc_conv_descriptor_lbound_get (dest
, rank
));
927 size
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
928 size
, gfc_index_one_node
);
929 if (GFC_TYPE_ARRAY_RANK (type
) > 1)
930 size
= fold_build2_loc (input_location
, MULT_EXPR
,
931 gfc_array_index_type
, size
,
932 gfc_conv_descriptor_stride_get (dest
, rank
));
933 tree esize
= fold_convert (gfc_array_index_type
,
934 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
935 nelems
= gfc_evaluate_now (unshare_expr (size
), &block
);
936 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
937 nelems
, unshare_expr (esize
));
938 size
= gfc_evaluate_now (fold_convert (size_type_node
, size
),
940 nelems
= fold_build2_loc (input_location
, MINUS_EXPR
,
941 gfc_array_index_type
, nelems
,
945 size
= fold_convert (size_type_node
, TYPE_SIZE_UNIT (TREE_TYPE (type
)));
946 ptr
= gfc_create_var (pvoid_type_node
, NULL
);
947 gfc_allocate_using_malloc (&block
, ptr
, size
, NULL_TREE
);
948 if (GFC_DESCRIPTOR_TYPE_P (type
))
950 gfc_conv_descriptor_data_set (&block
, unshare_expr (dest
), ptr
);
951 tree etype
= gfc_get_element_type (type
);
952 ptr
= fold_convert (build_pointer_type (etype
), ptr
);
953 tree srcptr
= gfc_conv_descriptor_data_get (unshare_expr (src
));
954 srcptr
= fold_convert (build_pointer_type (etype
), srcptr
);
955 gfc_omp_linear_clause_add_loop (&block
, ptr
, srcptr
, add
, nelems
);
959 gfc_add_modify (&block
, unshare_expr (dest
),
960 fold_convert (TREE_TYPE (dest
), ptr
));
961 ptr
= fold_convert (TREE_TYPE (dest
), ptr
);
962 tree dstm
= build_fold_indirect_ref (ptr
);
963 tree srcm
= build_fold_indirect_ref (unshare_expr (src
));
964 gfc_add_modify (&block
, dstm
,
965 fold_build2 (PLUS_EXPR
, TREE_TYPE (add
), srcm
, add
));
967 return gfc_finish_block (&block
);
970 /* Build and return code destructing DECL. Return NULL if nothing
974 gfc_omp_clause_dtor (tree clause
, tree decl
)
976 tree type
= TREE_TYPE (decl
), tem
;
978 if ((! GFC_DESCRIPTOR_TYPE_P (type
)
979 || GFC_TYPE_ARRAY_AKIND (type
) != GFC_ARRAY_ALLOCATABLE
)
980 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause
)))
982 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
983 return gfc_walk_alloc_comps (decl
, NULL_TREE
,
984 OMP_CLAUSE_DECL (clause
),
985 WALK_ALLOC_COMPS_DTOR
);
989 if (GFC_DESCRIPTOR_TYPE_P (type
))
990 /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
991 to be deallocated if they were allocated. */
992 tem
= gfc_trans_dealloc_allocated (decl
, false, NULL
);
994 tem
= gfc_call_free (decl
);
995 tem
= gfc_omp_unshare_expr (tem
);
997 if (gfc_has_alloc_comps (type
, OMP_CLAUSE_DECL (clause
)))
1002 gfc_init_block (&block
);
1003 gfc_add_expr_to_block (&block
,
1004 gfc_walk_alloc_comps (decl
, NULL_TREE
,
1005 OMP_CLAUSE_DECL (clause
),
1006 WALK_ALLOC_COMPS_DTOR
));
1007 gfc_add_expr_to_block (&block
, tem
);
1008 then_b
= gfc_finish_block (&block
);
1010 tem
= fold_convert (pvoid_type_node
,
1011 GFC_DESCRIPTOR_TYPE_P (type
)
1012 ? gfc_conv_descriptor_data_get (decl
) : decl
);
1013 tem
= unshare_expr (tem
);
1014 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1015 tem
, null_pointer_node
);
1016 tem
= build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1017 then_b
, build_empty_stmt (input_location
));
1024 gfc_omp_finish_clause (tree c
, gimple_seq
*pre_p
)
1026 if (OMP_CLAUSE_CODE (c
) != OMP_CLAUSE_MAP
)
1029 tree decl
= OMP_CLAUSE_DECL (c
);
1030 tree c2
= NULL_TREE
, c3
= NULL_TREE
, c4
= NULL_TREE
;
1031 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
1033 if (!gfc_omp_privatize_by_reference (decl
)
1034 && !GFC_DECL_GET_SCALAR_POINTER (decl
)
1035 && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1036 && !GFC_DECL_CRAY_POINTEE (decl
)
1037 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
1039 tree orig_decl
= decl
;
1040 c4
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1041 OMP_CLAUSE_SET_MAP_KIND (c4
, GOMP_MAP_POINTER
);
1042 OMP_CLAUSE_DECL (c4
) = decl
;
1043 OMP_CLAUSE_SIZE (c4
) = size_int (0);
1044 decl
= build_fold_indirect_ref (decl
);
1045 OMP_CLAUSE_DECL (c
) = decl
;
1046 OMP_CLAUSE_SIZE (c
) = NULL_TREE
;
1047 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1048 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1049 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1051 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1052 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1053 OMP_CLAUSE_DECL (c3
) = unshare_expr (decl
);
1054 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1055 decl
= build_fold_indirect_ref (decl
);
1056 OMP_CLAUSE_DECL (c
) = decl
;
1059 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1062 gfc_start_block (&block
);
1063 tree type
= TREE_TYPE (decl
);
1064 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1065 ptr
= fold_convert (build_pointer_type (char_type_node
), ptr
);
1066 ptr
= build_fold_indirect_ref (ptr
);
1067 OMP_CLAUSE_DECL (c
) = ptr
;
1068 c2
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1069 OMP_CLAUSE_SET_MAP_KIND (c2
, GOMP_MAP_TO_PSET
);
1070 OMP_CLAUSE_DECL (c2
) = decl
;
1071 OMP_CLAUSE_SIZE (c2
) = TYPE_SIZE_UNIT (type
);
1072 c3
= build_omp_clause (OMP_CLAUSE_LOCATION (c
), OMP_CLAUSE_MAP
);
1073 OMP_CLAUSE_SET_MAP_KIND (c3
, GOMP_MAP_POINTER
);
1074 OMP_CLAUSE_DECL (c3
) = gfc_conv_descriptor_data_get (decl
);
1075 OMP_CLAUSE_SIZE (c3
) = size_int (0);
1076 tree size
= create_tmp_var (gfc_array_index_type
);
1077 tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
1078 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
1079 if (GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER
1080 || GFC_TYPE_ARRAY_AKIND (type
) == GFC_ARRAY_POINTER_CONT
)
1082 stmtblock_t cond_block
;
1083 tree tem
, then_b
, else_b
, zero
, cond
;
1085 gfc_init_block (&cond_block
);
1086 tem
= gfc_full_array_size (&cond_block
, decl
,
1087 GFC_TYPE_ARRAY_RANK (type
));
1088 gfc_add_modify (&cond_block
, size
, tem
);
1089 gfc_add_modify (&cond_block
, size
,
1090 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1092 then_b
= gfc_finish_block (&cond_block
);
1093 gfc_init_block (&cond_block
);
1094 zero
= build_int_cst (gfc_array_index_type
, 0);
1095 gfc_add_modify (&cond_block
, size
, zero
);
1096 else_b
= gfc_finish_block (&cond_block
);
1097 tem
= gfc_conv_descriptor_data_get (decl
);
1098 tem
= fold_convert (pvoid_type_node
, tem
);
1099 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1100 boolean_type_node
, tem
, null_pointer_node
);
1101 gfc_add_expr_to_block (&block
, build3_loc (input_location
, COND_EXPR
,
1102 void_type_node
, cond
,
1107 gfc_add_modify (&block
, size
,
1108 gfc_full_array_size (&block
, decl
,
1109 GFC_TYPE_ARRAY_RANK (type
)));
1110 gfc_add_modify (&block
, size
,
1111 fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1114 OMP_CLAUSE_SIZE (c
) = size
;
1115 tree stmt
= gfc_finish_block (&block
);
1116 gimplify_and_add (stmt
, pre_p
);
1119 if (OMP_CLAUSE_SIZE (c
) == NULL_TREE
)
1121 = DECL_P (decl
) ? DECL_SIZE_UNIT (decl
)
1122 : TYPE_SIZE_UNIT (TREE_TYPE (decl
));
1125 OMP_CLAUSE_CHAIN (c2
) = OMP_CLAUSE_CHAIN (last
);
1126 OMP_CLAUSE_CHAIN (last
) = c2
;
1131 OMP_CLAUSE_CHAIN (c3
) = OMP_CLAUSE_CHAIN (last
);
1132 OMP_CLAUSE_CHAIN (last
) = c3
;
1137 OMP_CLAUSE_CHAIN (c4
) = OMP_CLAUSE_CHAIN (last
);
1138 OMP_CLAUSE_CHAIN (last
) = c4
;
1144 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
1145 disregarded in OpenMP construct, because it is going to be
1146 remapped during OpenMP lowering. SHARED is true if DECL
1147 is going to be shared, false if it is going to be privatized. */
1150 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
1152 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1153 && DECL_HAS_VALUE_EXPR_P (decl
))
1155 tree value
= DECL_VALUE_EXPR (decl
);
1157 if (TREE_CODE (value
) == COMPONENT_REF
1158 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
1159 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1161 /* If variable in COMMON or EQUIVALENCE is privatized, return
1162 true, as just that variable is supposed to be privatized,
1163 not the whole COMMON or whole EQUIVALENCE.
1164 For shared variables in COMMON or EQUIVALENCE, let them be
1165 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
1166 from the same COMMON or EQUIVALENCE just one sharing of the
1167 whole COMMON or EQUIVALENCE is enough. */
1172 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
1178 /* Return true if DECL that is shared iff SHARED is true should
1179 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
1183 gfc_omp_private_debug_clause (tree decl
, bool shared
)
1185 if (GFC_DECL_CRAY_POINTEE (decl
))
1188 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
1189 && DECL_HAS_VALUE_EXPR_P (decl
))
1191 tree value
= DECL_VALUE_EXPR (decl
);
1193 if (TREE_CODE (value
) == COMPONENT_REF
1194 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
1195 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
1202 /* Register language specific type size variables as potentially OpenMP
1203 firstprivate variables. */
1206 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
1208 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
1212 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
1213 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
1215 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
1216 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
1217 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
1219 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
1220 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
1226 gfc_trans_add_clause (tree node
, tree tail
)
1228 OMP_CLAUSE_CHAIN (node
) = tail
;
1233 gfc_trans_omp_variable (gfc_symbol
*sym
, bool declare_simd
)
1238 gfc_symbol
*proc_sym
;
1239 gfc_formal_arglist
*f
;
1241 gcc_assert (sym
->attr
.dummy
);
1242 proc_sym
= sym
->ns
->proc_name
;
1243 if (proc_sym
->attr
.entry_master
)
1245 if (gfc_return_by_reference (proc_sym
))
1248 if (proc_sym
->ts
.type
== BT_CHARACTER
)
1251 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
1257 return build_int_cst (integer_type_node
, cnt
);
1260 tree t
= gfc_get_symbol_decl (sym
);
1264 bool alternate_entry
;
1267 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1268 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1269 && sym
->result
== sym
;
1270 entry_master
= sym
->attr
.result
1271 && sym
->ns
->proc_name
->attr
.entry_master
1272 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1273 parent_decl
= current_function_decl
1274 ? DECL_CONTEXT (current_function_decl
) : NULL_TREE
;
1276 if ((t
== parent_decl
&& return_value
)
1277 || (sym
->ns
&& sym
->ns
->proc_name
1278 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1279 && (alternate_entry
|| entry_master
)))
1284 /* Special case for assigning the return value of a function.
1285 Self recursive functions must have an explicit return value. */
1286 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
1287 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1289 /* Similarly for alternate entry points. */
1290 else if (alternate_entry
1291 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1294 gfc_entry_list
*el
= NULL
;
1296 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1299 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1304 else if (entry_master
1305 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1307 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
1313 gfc_trans_omp_variable_list (enum omp_clause_code code
,
1314 gfc_omp_namelist
*namelist
, tree list
,
1317 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1318 if (namelist
->sym
->attr
.referenced
|| declare_simd
)
1320 tree t
= gfc_trans_omp_variable (namelist
->sym
, declare_simd
);
1321 if (t
!= error_mark_node
)
1323 tree node
= build_omp_clause (input_location
, code
);
1324 OMP_CLAUSE_DECL (node
) = t
;
1325 list
= gfc_trans_add_clause (node
, list
);
1331 struct omp_udr_find_orig_data
1333 gfc_omp_udr
*omp_udr
;
1338 omp_udr_find_orig (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1341 struct omp_udr_find_orig_data
*cd
= (struct omp_udr_find_orig_data
*) data
;
1342 if ((*e
)->expr_type
== EXPR_VARIABLE
1343 && (*e
)->symtree
->n
.sym
== cd
->omp_udr
->omp_orig
)
1344 cd
->omp_orig_seen
= true;
1350 gfc_trans_omp_array_reduction_or_udr (tree c
, gfc_omp_namelist
*n
, locus where
)
1352 gfc_symbol
*sym
= n
->sym
;
1353 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
1354 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
1355 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
1356 gfc_symbol omp_var_copy
[4];
1357 gfc_expr
*e1
, *e2
, *e3
, *e4
;
1359 tree decl
, backend_decl
, stmt
, type
, outer_decl
;
1360 locus old_loc
= gfc_current_locus
;
1363 gfc_omp_udr
*udr
= n
->udr
? n
->udr
->udr
: NULL
;
1365 decl
= OMP_CLAUSE_DECL (c
);
1366 gfc_current_locus
= where
;
1367 type
= TREE_TYPE (decl
);
1368 outer_decl
= create_tmp_var_raw (type
);
1369 if (TREE_CODE (decl
) == PARM_DECL
1370 && TREE_CODE (type
) == REFERENCE_TYPE
1371 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
))
1372 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type
)) == GFC_ARRAY_ALLOCATABLE
)
1374 decl
= build_fold_indirect_ref (decl
);
1375 type
= TREE_TYPE (type
);
1378 /* Create a fake symbol for init value. */
1379 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
1380 init_val_sym
.ns
= sym
->ns
;
1381 init_val_sym
.name
= sym
->name
;
1382 init_val_sym
.ts
= sym
->ts
;
1383 init_val_sym
.attr
.referenced
= 1;
1384 init_val_sym
.declared_at
= where
;
1385 init_val_sym
.attr
.flavor
= FL_VARIABLE
;
1386 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1387 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
1388 else if (udr
->initializer_ns
)
1389 backend_decl
= NULL
;
1391 switch (sym
->ts
.type
)
1397 backend_decl
= build_zero_cst (gfc_sym_type (&init_val_sym
));
1400 backend_decl
= NULL_TREE
;
1403 init_val_sym
.backend_decl
= backend_decl
;
1405 /* Create a fake symbol for the outer array reference. */
1408 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
1409 outer_sym
.attr
.dummy
= 0;
1410 outer_sym
.attr
.result
= 0;
1411 outer_sym
.attr
.flavor
= FL_VARIABLE
;
1412 outer_sym
.backend_decl
= outer_decl
;
1413 if (decl
!= OMP_CLAUSE_DECL (c
))
1414 outer_sym
.backend_decl
= build_fold_indirect_ref (outer_decl
);
1416 /* Create fake symtrees for it. */
1417 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
1418 symtree1
->n
.sym
= sym
;
1419 gcc_assert (symtree1
== root1
);
1421 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
1422 symtree2
->n
.sym
= &init_val_sym
;
1423 gcc_assert (symtree2
== root2
);
1425 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
1426 symtree3
->n
.sym
= &outer_sym
;
1427 gcc_assert (symtree3
== root3
);
1429 memset (omp_var_copy
, 0, sizeof omp_var_copy
);
1432 omp_var_copy
[0] = *udr
->omp_out
;
1433 omp_var_copy
[1] = *udr
->omp_in
;
1434 *udr
->omp_out
= outer_sym
;
1435 *udr
->omp_in
= *sym
;
1436 if (udr
->initializer_ns
)
1438 omp_var_copy
[2] = *udr
->omp_priv
;
1439 omp_var_copy
[3] = *udr
->omp_orig
;
1440 *udr
->omp_priv
= *sym
;
1441 *udr
->omp_orig
= outer_sym
;
1445 /* Create expressions. */
1446 e1
= gfc_get_expr ();
1447 e1
->expr_type
= EXPR_VARIABLE
;
1449 e1
->symtree
= symtree1
;
1451 if (sym
->attr
.dimension
)
1453 e1
->ref
= ref
= gfc_get_ref ();
1454 ref
->type
= REF_ARRAY
;
1455 ref
->u
.ar
.where
= where
;
1456 ref
->u
.ar
.as
= sym
->as
;
1457 ref
->u
.ar
.type
= AR_FULL
;
1458 ref
->u
.ar
.dimen
= 0;
1460 t
= gfc_resolve_expr (e1
);
1464 if (backend_decl
!= NULL_TREE
)
1466 e2
= gfc_get_expr ();
1467 e2
->expr_type
= EXPR_VARIABLE
;
1469 e2
->symtree
= symtree2
;
1471 t
= gfc_resolve_expr (e2
);
1474 else if (udr
->initializer_ns
== NULL
)
1476 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
1477 e2
= gfc_default_initializer (&sym
->ts
);
1479 t
= gfc_resolve_expr (e2
);
1482 else if (n
->udr
->initializer
->op
== EXEC_ASSIGN
)
1484 e2
= gfc_copy_expr (n
->udr
->initializer
->expr2
);
1485 t
= gfc_resolve_expr (e2
);
1488 if (udr
&& udr
->initializer_ns
)
1490 struct omp_udr_find_orig_data cd
;
1492 cd
.omp_orig_seen
= false;
1493 gfc_code_walker (&n
->udr
->initializer
,
1494 gfc_dummy_code_callback
, omp_udr_find_orig
, &cd
);
1495 if (cd
.omp_orig_seen
)
1496 OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c
) = 1;
1499 e3
= gfc_copy_expr (e1
);
1500 e3
->symtree
= symtree3
;
1501 t
= gfc_resolve_expr (e3
);
1506 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
1510 e4
= gfc_add (e3
, e1
);
1513 e4
= gfc_multiply (e3
, e1
);
1515 case TRUTH_ANDIF_EXPR
:
1516 e4
= gfc_and (e3
, e1
);
1518 case TRUTH_ORIF_EXPR
:
1519 e4
= gfc_or (e3
, e1
);
1522 e4
= gfc_eqv (e3
, e1
);
1525 e4
= gfc_neqv (e3
, e1
);
1543 if (n
->udr
->combiner
->op
== EXEC_ASSIGN
)
1546 e3
= gfc_copy_expr (n
->udr
->combiner
->expr1
);
1547 e4
= gfc_copy_expr (n
->udr
->combiner
->expr2
);
1548 t
= gfc_resolve_expr (e3
);
1550 t
= gfc_resolve_expr (e4
);
1559 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
1560 intrinsic_sym
.ns
= sym
->ns
;
1561 intrinsic_sym
.name
= iname
;
1562 intrinsic_sym
.ts
= sym
->ts
;
1563 intrinsic_sym
.attr
.referenced
= 1;
1564 intrinsic_sym
.attr
.intrinsic
= 1;
1565 intrinsic_sym
.attr
.function
= 1;
1566 intrinsic_sym
.result
= &intrinsic_sym
;
1567 intrinsic_sym
.declared_at
= where
;
1569 symtree4
= gfc_new_symtree (&root4
, iname
);
1570 symtree4
->n
.sym
= &intrinsic_sym
;
1571 gcc_assert (symtree4
== root4
);
1573 e4
= gfc_get_expr ();
1574 e4
->expr_type
= EXPR_FUNCTION
;
1576 e4
->symtree
= symtree4
;
1577 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
1578 e4
->value
.function
.actual
->expr
= e3
;
1579 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
1580 e4
->value
.function
.actual
->next
->expr
= e1
;
1582 if (OMP_CLAUSE_REDUCTION_CODE (c
) != ERROR_MARK
)
1584 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
1585 e1
= gfc_copy_expr (e1
);
1586 e3
= gfc_copy_expr (e3
);
1587 t
= gfc_resolve_expr (e4
);
1591 /* Create the init statement list. */
1594 stmt
= gfc_trans_assignment (e1
, e2
, false, false);
1596 stmt
= gfc_trans_call (n
->udr
->initializer
, false,
1597 NULL_TREE
, NULL_TREE
, false);
1598 if (TREE_CODE (stmt
) != BIND_EXPR
)
1599 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1602 OMP_CLAUSE_REDUCTION_INIT (c
) = stmt
;
1604 /* Create the merge statement list. */
1607 stmt
= gfc_trans_assignment (e3
, e4
, false, true);
1609 stmt
= gfc_trans_call (n
->udr
->combiner
, false,
1610 NULL_TREE
, NULL_TREE
, false);
1611 if (TREE_CODE (stmt
) != BIND_EXPR
)
1612 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
1615 OMP_CLAUSE_REDUCTION_MERGE (c
) = stmt
;
1617 /* And stick the placeholder VAR_DECL into the clause as well. */
1618 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_decl
;
1620 gfc_current_locus
= old_loc
;
1633 gfc_free_array_spec (outer_sym
.as
);
1637 *udr
->omp_out
= omp_var_copy
[0];
1638 *udr
->omp_in
= omp_var_copy
[1];
1639 if (udr
->initializer_ns
)
1641 *udr
->omp_priv
= omp_var_copy
[2];
1642 *udr
->omp_orig
= omp_var_copy
[3];
1648 gfc_trans_omp_reduction_list (gfc_omp_namelist
*namelist
, tree list
,
1649 locus where
, bool mark_addressable
)
1651 for (; namelist
!= NULL
; namelist
= namelist
->next
)
1652 if (namelist
->sym
->attr
.referenced
)
1654 tree t
= gfc_trans_omp_variable (namelist
->sym
, false);
1655 if (t
!= error_mark_node
)
1657 tree node
= build_omp_clause (where
.lb
->location
,
1658 OMP_CLAUSE_REDUCTION
);
1659 OMP_CLAUSE_DECL (node
) = t
;
1660 if (mark_addressable
)
1661 TREE_ADDRESSABLE (t
) = 1;
1662 switch (namelist
->u
.reduction_op
)
1664 case OMP_REDUCTION_PLUS
:
1665 OMP_CLAUSE_REDUCTION_CODE (node
) = PLUS_EXPR
;
1667 case OMP_REDUCTION_MINUS
:
1668 OMP_CLAUSE_REDUCTION_CODE (node
) = MINUS_EXPR
;
1670 case OMP_REDUCTION_TIMES
:
1671 OMP_CLAUSE_REDUCTION_CODE (node
) = MULT_EXPR
;
1673 case OMP_REDUCTION_AND
:
1674 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ANDIF_EXPR
;
1676 case OMP_REDUCTION_OR
:
1677 OMP_CLAUSE_REDUCTION_CODE (node
) = TRUTH_ORIF_EXPR
;
1679 case OMP_REDUCTION_EQV
:
1680 OMP_CLAUSE_REDUCTION_CODE (node
) = EQ_EXPR
;
1682 case OMP_REDUCTION_NEQV
:
1683 OMP_CLAUSE_REDUCTION_CODE (node
) = NE_EXPR
;
1685 case OMP_REDUCTION_MAX
:
1686 OMP_CLAUSE_REDUCTION_CODE (node
) = MAX_EXPR
;
1688 case OMP_REDUCTION_MIN
:
1689 OMP_CLAUSE_REDUCTION_CODE (node
) = MIN_EXPR
;
1691 case OMP_REDUCTION_IAND
:
1692 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_AND_EXPR
;
1694 case OMP_REDUCTION_IOR
:
1695 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_IOR_EXPR
;
1697 case OMP_REDUCTION_IEOR
:
1698 OMP_CLAUSE_REDUCTION_CODE (node
) = BIT_XOR_EXPR
;
1700 case OMP_REDUCTION_USER
:
1701 OMP_CLAUSE_REDUCTION_CODE (node
) = ERROR_MARK
;
1706 if (namelist
->sym
->attr
.dimension
1707 || namelist
->u
.reduction_op
== OMP_REDUCTION_USER
1708 || namelist
->sym
->attr
.allocatable
)
1709 gfc_trans_omp_array_reduction_or_udr (node
, namelist
, where
);
1710 list
= gfc_trans_add_clause (node
, list
);
1717 gfc_convert_expr_to_tree (stmtblock_t
*block
, gfc_expr
*expr
)
1722 gfc_init_se (&se
, NULL
);
1723 gfc_conv_expr (&se
, expr
);
1724 gfc_add_block_to_block (block
, &se
.pre
);
1725 result
= gfc_evaluate_now (se
.expr
, block
);
1726 gfc_add_block_to_block (block
, &se
.post
);
1732 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
1733 locus where
, bool declare_simd
= false)
1735 tree omp_clauses
= NULL_TREE
, chunk_size
, c
;
1737 enum omp_clause_code clause_code
;
1740 if (clauses
== NULL
)
1743 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1745 gfc_omp_namelist
*n
= clauses
->lists
[list
];
1751 case OMP_LIST_REDUCTION
:
1752 /* An OpenACC async clause indicates the need to set reduction
1753 arguments addressable, to allow asynchronous copy-out. */
1754 omp_clauses
= gfc_trans_omp_reduction_list (n
, omp_clauses
, where
,
1757 case OMP_LIST_PRIVATE
:
1758 clause_code
= OMP_CLAUSE_PRIVATE
;
1760 case OMP_LIST_SHARED
:
1761 clause_code
= OMP_CLAUSE_SHARED
;
1763 case OMP_LIST_FIRSTPRIVATE
:
1764 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
1766 case OMP_LIST_LASTPRIVATE
:
1767 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
1769 case OMP_LIST_COPYIN
:
1770 clause_code
= OMP_CLAUSE_COPYIN
;
1772 case OMP_LIST_COPYPRIVATE
:
1773 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
1775 case OMP_LIST_UNIFORM
:
1776 clause_code
= OMP_CLAUSE_UNIFORM
;
1778 case OMP_LIST_USE_DEVICE
:
1779 clause_code
= OMP_CLAUSE_USE_DEVICE_PTR
;
1784 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
,
1787 case OMP_LIST_ALIGNED
:
1788 for (; n
!= NULL
; n
= n
->next
)
1789 if (n
->sym
->attr
.referenced
|| declare_simd
)
1791 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
1792 if (t
!= error_mark_node
)
1794 tree node
= build_omp_clause (input_location
,
1795 OMP_CLAUSE_ALIGNED
);
1796 OMP_CLAUSE_DECL (node
) = t
;
1802 alignment_var
= gfc_conv_constant_to_tree (n
->expr
);
1805 gfc_init_se (&se
, NULL
);
1806 gfc_conv_expr (&se
, n
->expr
);
1807 gfc_add_block_to_block (block
, &se
.pre
);
1808 alignment_var
= gfc_evaluate_now (se
.expr
, block
);
1809 gfc_add_block_to_block (block
, &se
.post
);
1811 OMP_CLAUSE_ALIGNED_ALIGNMENT (node
) = alignment_var
;
1813 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
1817 case OMP_LIST_LINEAR
:
1819 gfc_expr
*last_step_expr
= NULL
;
1820 tree last_step
= NULL_TREE
;
1822 for (; n
!= NULL
; n
= n
->next
)
1826 last_step_expr
= n
->expr
;
1827 last_step
= NULL_TREE
;
1829 if (n
->sym
->attr
.referenced
|| declare_simd
)
1831 tree t
= gfc_trans_omp_variable (n
->sym
, declare_simd
);
1832 if (t
!= error_mark_node
)
1834 tree node
= build_omp_clause (input_location
,
1836 OMP_CLAUSE_DECL (node
) = t
;
1837 if (last_step_expr
&& last_step
== NULL_TREE
)
1841 = gfc_conv_constant_to_tree (last_step_expr
);
1844 gfc_init_se (&se
, NULL
);
1845 gfc_conv_expr (&se
, last_step_expr
);
1846 gfc_add_block_to_block (block
, &se
.pre
);
1847 last_step
= gfc_evaluate_now (se
.expr
, block
);
1848 gfc_add_block_to_block (block
, &se
.post
);
1851 OMP_CLAUSE_LINEAR_STEP (node
)
1852 = fold_convert (gfc_typenode_for_spec (&n
->sym
->ts
),
1854 if (n
->sym
->attr
.dimension
|| n
->sym
->attr
.allocatable
)
1855 OMP_CLAUSE_LINEAR_ARRAY (node
) = 1;
1856 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
1862 case OMP_LIST_DEPEND
:
1863 for (; n
!= NULL
; n
= n
->next
)
1865 if (!n
->sym
->attr
.referenced
)
1868 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_DEPEND
);
1869 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
1871 tree decl
= gfc_get_symbol_decl (n
->sym
);
1872 if (gfc_omp_privatize_by_reference (decl
))
1873 decl
= build_fold_indirect_ref (decl
);
1874 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1876 decl
= gfc_conv_descriptor_data_get (decl
);
1877 decl
= fold_convert (build_pointer_type (char_type_node
),
1879 decl
= build_fold_indirect_ref (decl
);
1881 else if (DECL_P (decl
))
1882 TREE_ADDRESSABLE (decl
) = 1;
1883 OMP_CLAUSE_DECL (node
) = decl
;
1888 gfc_init_se (&se
, NULL
);
1889 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
1891 gfc_conv_expr_reference (&se
, n
->expr
);
1896 gfc_conv_expr_descriptor (&se
, n
->expr
);
1897 ptr
= gfc_conv_array_data (se
.expr
);
1899 gfc_add_block_to_block (block
, &se
.pre
);
1900 gfc_add_block_to_block (block
, &se
.post
);
1901 ptr
= fold_convert (build_pointer_type (char_type_node
),
1903 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
1905 switch (n
->u
.depend_op
)
1908 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_IN
;
1910 case OMP_DEPEND_OUT
:
1911 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_OUT
;
1913 case OMP_DEPEND_INOUT
:
1914 OMP_CLAUSE_DEPEND_KIND (node
) = OMP_CLAUSE_DEPEND_INOUT
;
1919 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
1923 for (; n
!= NULL
; n
= n
->next
)
1925 if (!n
->sym
->attr
.referenced
)
1928 tree node
= build_omp_clause (input_location
, OMP_CLAUSE_MAP
);
1929 tree node2
= NULL_TREE
;
1930 tree node3
= NULL_TREE
;
1931 tree node4
= NULL_TREE
;
1932 tree decl
= gfc_get_symbol_decl (n
->sym
);
1934 TREE_ADDRESSABLE (decl
) = 1;
1935 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
1937 if (POINTER_TYPE_P (TREE_TYPE (decl
))
1938 && (gfc_omp_privatize_by_reference (decl
)
1939 || GFC_DECL_GET_SCALAR_POINTER (decl
)
1940 || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl
)
1941 || GFC_DECL_CRAY_POINTEE (decl
)
1942 || GFC_DESCRIPTOR_TYPE_P
1943 (TREE_TYPE (TREE_TYPE (decl
)))))
1945 tree orig_decl
= decl
;
1946 node4
= build_omp_clause (input_location
,
1948 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
1949 OMP_CLAUSE_DECL (node4
) = decl
;
1950 OMP_CLAUSE_SIZE (node4
) = size_int (0);
1951 decl
= build_fold_indirect_ref (decl
);
1952 if (TREE_CODE (TREE_TYPE (orig_decl
)) == REFERENCE_TYPE
1953 && (GFC_DECL_GET_SCALAR_POINTER (orig_decl
)
1954 || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl
)))
1956 node3
= build_omp_clause (input_location
,
1958 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
1959 OMP_CLAUSE_DECL (node3
) = decl
;
1960 OMP_CLAUSE_SIZE (node3
) = size_int (0);
1961 decl
= build_fold_indirect_ref (decl
);
1964 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
1966 tree type
= TREE_TYPE (decl
);
1967 tree ptr
= gfc_conv_descriptor_data_get (decl
);
1968 ptr
= fold_convert (build_pointer_type (char_type_node
),
1970 ptr
= build_fold_indirect_ref (ptr
);
1971 OMP_CLAUSE_DECL (node
) = ptr
;
1972 node2
= build_omp_clause (input_location
,
1974 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
1975 OMP_CLAUSE_DECL (node2
) = decl
;
1976 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
1977 node3
= build_omp_clause (input_location
,
1979 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
1980 OMP_CLAUSE_DECL (node3
)
1981 = gfc_conv_descriptor_data_get (decl
);
1982 OMP_CLAUSE_SIZE (node3
) = size_int (0);
1984 /* We have to check for n->sym->attr.dimension because
1985 of scalar coarrays. */
1986 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.dimension
)
1988 stmtblock_t cond_block
;
1990 = gfc_create_var (gfc_array_index_type
, NULL
);
1991 tree tem
, then_b
, else_b
, zero
, cond
;
1993 gfc_init_block (&cond_block
);
1995 = gfc_full_array_size (&cond_block
, decl
,
1996 GFC_TYPE_ARRAY_RANK (type
));
1997 gfc_add_modify (&cond_block
, size
, tem
);
1998 then_b
= gfc_finish_block (&cond_block
);
1999 gfc_init_block (&cond_block
);
2000 zero
= build_int_cst (gfc_array_index_type
, 0);
2001 gfc_add_modify (&cond_block
, size
, zero
);
2002 else_b
= gfc_finish_block (&cond_block
);
2003 tem
= gfc_conv_descriptor_data_get (decl
);
2004 tem
= fold_convert (pvoid_type_node
, tem
);
2005 cond
= fold_build2_loc (input_location
, NE_EXPR
,
2007 tem
, null_pointer_node
);
2008 gfc_add_expr_to_block (block
,
2009 build3_loc (input_location
,
2014 OMP_CLAUSE_SIZE (node
) = size
;
2016 else if (n
->sym
->attr
.dimension
)
2017 OMP_CLAUSE_SIZE (node
)
2018 = gfc_full_array_size (block
, decl
,
2019 GFC_TYPE_ARRAY_RANK (type
));
2020 if (n
->sym
->attr
.dimension
)
2023 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2024 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2025 OMP_CLAUSE_SIZE (node
)
2026 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2027 OMP_CLAUSE_SIZE (node
), elemsz
);
2031 OMP_CLAUSE_DECL (node
) = decl
;
2036 gfc_init_se (&se
, NULL
);
2037 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2039 gfc_conv_expr_reference (&se
, n
->expr
);
2040 gfc_add_block_to_block (block
, &se
.pre
);
2042 OMP_CLAUSE_SIZE (node
)
2043 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
2047 gfc_conv_expr_descriptor (&se
, n
->expr
);
2048 ptr
= gfc_conv_array_data (se
.expr
);
2049 tree type
= TREE_TYPE (se
.expr
);
2050 gfc_add_block_to_block (block
, &se
.pre
);
2051 OMP_CLAUSE_SIZE (node
)
2052 = gfc_full_array_size (block
, se
.expr
,
2053 GFC_TYPE_ARRAY_RANK (type
));
2055 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2056 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2057 OMP_CLAUSE_SIZE (node
)
2058 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2059 OMP_CLAUSE_SIZE (node
), elemsz
);
2061 gfc_add_block_to_block (block
, &se
.post
);
2062 ptr
= fold_convert (build_pointer_type (char_type_node
),
2064 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2066 if (POINTER_TYPE_P (TREE_TYPE (decl
))
2067 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl
))))
2069 node4
= build_omp_clause (input_location
,
2071 OMP_CLAUSE_SET_MAP_KIND (node4
, GOMP_MAP_POINTER
);
2072 OMP_CLAUSE_DECL (node4
) = decl
;
2073 OMP_CLAUSE_SIZE (node4
) = size_int (0);
2074 decl
= build_fold_indirect_ref (decl
);
2076 ptr
= fold_convert (sizetype
, ptr
);
2077 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2079 tree type
= TREE_TYPE (decl
);
2080 ptr2
= gfc_conv_descriptor_data_get (decl
);
2081 node2
= build_omp_clause (input_location
,
2083 OMP_CLAUSE_SET_MAP_KIND (node2
, GOMP_MAP_TO_PSET
);
2084 OMP_CLAUSE_DECL (node2
) = decl
;
2085 OMP_CLAUSE_SIZE (node2
) = TYPE_SIZE_UNIT (type
);
2086 node3
= build_omp_clause (input_location
,
2088 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2089 OMP_CLAUSE_DECL (node3
)
2090 = gfc_conv_descriptor_data_get (decl
);
2094 if (TREE_CODE (TREE_TYPE (decl
)) == ARRAY_TYPE
)
2095 ptr2
= build_fold_addr_expr (decl
);
2098 gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl
)));
2101 node3
= build_omp_clause (input_location
,
2103 OMP_CLAUSE_SET_MAP_KIND (node3
, GOMP_MAP_POINTER
);
2104 OMP_CLAUSE_DECL (node3
) = decl
;
2106 ptr2
= fold_convert (sizetype
, ptr2
);
2107 OMP_CLAUSE_SIZE (node3
)
2108 = fold_build2 (MINUS_EXPR
, sizetype
, ptr
, ptr2
);
2110 switch (n
->u
.map_op
)
2113 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_ALLOC
);
2116 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TO
);
2119 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FROM
);
2121 case OMP_MAP_TOFROM
:
2122 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_TOFROM
);
2124 case OMP_MAP_DELETE
:
2125 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_DELETE
);
2127 case OMP_MAP_FORCE_ALLOC
:
2128 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_ALLOC
);
2130 case OMP_MAP_FORCE_TO
:
2131 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TO
);
2133 case OMP_MAP_FORCE_FROM
:
2134 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_FROM
);
2136 case OMP_MAP_FORCE_TOFROM
:
2137 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_TOFROM
);
2139 case OMP_MAP_FORCE_PRESENT
:
2140 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_PRESENT
);
2142 case OMP_MAP_FORCE_DEVICEPTR
:
2143 OMP_CLAUSE_SET_MAP_KIND (node
, GOMP_MAP_FORCE_DEVICEPTR
);
2148 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2150 omp_clauses
= gfc_trans_add_clause (node2
, omp_clauses
);
2152 omp_clauses
= gfc_trans_add_clause (node3
, omp_clauses
);
2154 omp_clauses
= gfc_trans_add_clause (node4
, omp_clauses
);
2159 case OMP_LIST_CACHE
:
2160 for (; n
!= NULL
; n
= n
->next
)
2162 if (!n
->sym
->attr
.referenced
)
2168 clause_code
= OMP_CLAUSE_TO
;
2171 clause_code
= OMP_CLAUSE_FROM
;
2173 case OMP_LIST_CACHE
:
2174 clause_code
= OMP_CLAUSE__CACHE_
;
2179 tree node
= build_omp_clause (input_location
, clause_code
);
2180 if (n
->expr
== NULL
|| n
->expr
->ref
->u
.ar
.type
== AR_FULL
)
2182 tree decl
= gfc_get_symbol_decl (n
->sym
);
2183 if (gfc_omp_privatize_by_reference (decl
))
2184 decl
= build_fold_indirect_ref (decl
);
2185 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
2187 tree type
= TREE_TYPE (decl
);
2188 tree ptr
= gfc_conv_descriptor_data_get (decl
);
2189 ptr
= fold_convert (build_pointer_type (char_type_node
),
2191 ptr
= build_fold_indirect_ref (ptr
);
2192 OMP_CLAUSE_DECL (node
) = ptr
;
2193 OMP_CLAUSE_SIZE (node
)
2194 = gfc_full_array_size (block
, decl
,
2195 GFC_TYPE_ARRAY_RANK (type
));
2197 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2198 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2199 OMP_CLAUSE_SIZE (node
)
2200 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2201 OMP_CLAUSE_SIZE (node
), elemsz
);
2204 OMP_CLAUSE_DECL (node
) = decl
;
2209 gfc_init_se (&se
, NULL
);
2210 if (n
->expr
->ref
->u
.ar
.type
== AR_ELEMENT
)
2212 gfc_conv_expr_reference (&se
, n
->expr
);
2214 gfc_add_block_to_block (block
, &se
.pre
);
2215 OMP_CLAUSE_SIZE (node
)
2216 = TYPE_SIZE_UNIT (TREE_TYPE (ptr
));
2220 gfc_conv_expr_descriptor (&se
, n
->expr
);
2221 ptr
= gfc_conv_array_data (se
.expr
);
2222 tree type
= TREE_TYPE (se
.expr
);
2223 gfc_add_block_to_block (block
, &se
.pre
);
2224 OMP_CLAUSE_SIZE (node
)
2225 = gfc_full_array_size (block
, se
.expr
,
2226 GFC_TYPE_ARRAY_RANK (type
));
2228 = TYPE_SIZE_UNIT (gfc_get_element_type (type
));
2229 elemsz
= fold_convert (gfc_array_index_type
, elemsz
);
2230 OMP_CLAUSE_SIZE (node
)
2231 = fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2232 OMP_CLAUSE_SIZE (node
), elemsz
);
2234 gfc_add_block_to_block (block
, &se
.post
);
2235 ptr
= fold_convert (build_pointer_type (char_type_node
),
2237 OMP_CLAUSE_DECL (node
) = build_fold_indirect_ref (ptr
);
2239 omp_clauses
= gfc_trans_add_clause (node
, omp_clauses
);
2247 if (clauses
->if_expr
)
2251 gfc_init_se (&se
, NULL
);
2252 gfc_conv_expr (&se
, clauses
->if_expr
);
2253 gfc_add_block_to_block (block
, &se
.pre
);
2254 if_var
= gfc_evaluate_now (se
.expr
, block
);
2255 gfc_add_block_to_block (block
, &se
.post
);
2257 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_IF
);
2258 OMP_CLAUSE_IF_MODIFIER (c
) = ERROR_MARK
;
2259 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
2260 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2263 if (clauses
->final_expr
)
2267 gfc_init_se (&se
, NULL
);
2268 gfc_conv_expr (&se
, clauses
->final_expr
);
2269 gfc_add_block_to_block (block
, &se
.pre
);
2270 final_var
= gfc_evaluate_now (se
.expr
, block
);
2271 gfc_add_block_to_block (block
, &se
.post
);
2273 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_FINAL
);
2274 OMP_CLAUSE_FINAL_EXPR (c
) = final_var
;
2275 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2278 if (clauses
->num_threads
)
2282 gfc_init_se (&se
, NULL
);
2283 gfc_conv_expr (&se
, clauses
->num_threads
);
2284 gfc_add_block_to_block (block
, &se
.pre
);
2285 num_threads
= gfc_evaluate_now (se
.expr
, block
);
2286 gfc_add_block_to_block (block
, &se
.post
);
2288 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_THREADS
);
2289 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
2290 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2293 chunk_size
= NULL_TREE
;
2294 if (clauses
->chunk_size
)
2296 gfc_init_se (&se
, NULL
);
2297 gfc_conv_expr (&se
, clauses
->chunk_size
);
2298 gfc_add_block_to_block (block
, &se
.pre
);
2299 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
2300 gfc_add_block_to_block (block
, &se
.post
);
2303 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
2305 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SCHEDULE
);
2306 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
2307 switch (clauses
->sched_kind
)
2309 case OMP_SCHED_STATIC
:
2310 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
2312 case OMP_SCHED_DYNAMIC
:
2313 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
2315 case OMP_SCHED_GUIDED
:
2316 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
2318 case OMP_SCHED_RUNTIME
:
2319 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
2321 case OMP_SCHED_AUTO
:
2322 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_AUTO
;
2327 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2330 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
2332 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEFAULT
);
2333 switch (clauses
->default_sharing
)
2335 case OMP_DEFAULT_NONE
:
2336 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
2338 case OMP_DEFAULT_SHARED
:
2339 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
2341 case OMP_DEFAULT_PRIVATE
:
2342 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
2344 case OMP_DEFAULT_FIRSTPRIVATE
:
2345 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE
;
2350 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2353 if (clauses
->nowait
)
2355 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOWAIT
);
2356 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2359 if (clauses
->ordered
)
2361 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_ORDERED
);
2362 OMP_CLAUSE_ORDERED_EXPR (c
) = NULL_TREE
;
2363 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2366 if (clauses
->untied
)
2368 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_UNTIED
);
2369 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2372 if (clauses
->mergeable
)
2374 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_MERGEABLE
);
2375 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2378 if (clauses
->collapse
)
2380 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_COLLAPSE
);
2381 OMP_CLAUSE_COLLAPSE_EXPR (c
)
2382 = build_int_cst (integer_type_node
, clauses
->collapse
);
2383 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2386 if (clauses
->inbranch
)
2388 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_INBRANCH
);
2389 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2392 if (clauses
->notinbranch
)
2394 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NOTINBRANCH
);
2395 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2398 switch (clauses
->cancel
)
2400 case OMP_CANCEL_UNKNOWN
:
2402 case OMP_CANCEL_PARALLEL
:
2403 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_PARALLEL
);
2404 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2406 case OMP_CANCEL_SECTIONS
:
2407 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SECTIONS
);
2408 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2411 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_FOR
);
2412 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2414 case OMP_CANCEL_TASKGROUP
:
2415 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_TASKGROUP
);
2416 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2420 if (clauses
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
2422 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_PROC_BIND
);
2423 switch (clauses
->proc_bind
)
2425 case OMP_PROC_BIND_MASTER
:
2426 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_MASTER
;
2428 case OMP_PROC_BIND_SPREAD
:
2429 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_SPREAD
;
2431 case OMP_PROC_BIND_CLOSE
:
2432 OMP_CLAUSE_PROC_BIND_KIND (c
) = OMP_CLAUSE_PROC_BIND_CLOSE
;
2437 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2440 if (clauses
->safelen_expr
)
2444 gfc_init_se (&se
, NULL
);
2445 gfc_conv_expr (&se
, clauses
->safelen_expr
);
2446 gfc_add_block_to_block (block
, &se
.pre
);
2447 safelen_var
= gfc_evaluate_now (se
.expr
, block
);
2448 gfc_add_block_to_block (block
, &se
.post
);
2450 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SAFELEN
);
2451 OMP_CLAUSE_SAFELEN_EXPR (c
) = safelen_var
;
2452 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2455 if (clauses
->simdlen_expr
)
2457 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SIMDLEN
);
2458 OMP_CLAUSE_SIMDLEN_EXPR (c
)
2459 = gfc_conv_constant_to_tree (clauses
->simdlen_expr
);
2460 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2463 if (clauses
->num_teams
)
2467 gfc_init_se (&se
, NULL
);
2468 gfc_conv_expr (&se
, clauses
->num_teams
);
2469 gfc_add_block_to_block (block
, &se
.pre
);
2470 num_teams
= gfc_evaluate_now (se
.expr
, block
);
2471 gfc_add_block_to_block (block
, &se
.post
);
2473 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_TEAMS
);
2474 OMP_CLAUSE_NUM_TEAMS_EXPR (c
) = num_teams
;
2475 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2478 if (clauses
->device
)
2482 gfc_init_se (&se
, NULL
);
2483 gfc_conv_expr (&se
, clauses
->device
);
2484 gfc_add_block_to_block (block
, &se
.pre
);
2485 device
= gfc_evaluate_now (se
.expr
, block
);
2486 gfc_add_block_to_block (block
, &se
.post
);
2488 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DEVICE
);
2489 OMP_CLAUSE_DEVICE_ID (c
) = device
;
2490 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2493 if (clauses
->thread_limit
)
2497 gfc_init_se (&se
, NULL
);
2498 gfc_conv_expr (&se
, clauses
->thread_limit
);
2499 gfc_add_block_to_block (block
, &se
.pre
);
2500 thread_limit
= gfc_evaluate_now (se
.expr
, block
);
2501 gfc_add_block_to_block (block
, &se
.post
);
2503 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_THREAD_LIMIT
);
2504 OMP_CLAUSE_THREAD_LIMIT_EXPR (c
) = thread_limit
;
2505 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2508 chunk_size
= NULL_TREE
;
2509 if (clauses
->dist_chunk_size
)
2511 gfc_init_se (&se
, NULL
);
2512 gfc_conv_expr (&se
, clauses
->dist_chunk_size
);
2513 gfc_add_block_to_block (block
, &se
.pre
);
2514 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
2515 gfc_add_block_to_block (block
, &se
.post
);
2518 if (clauses
->dist_sched_kind
!= OMP_SCHED_NONE
)
2520 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_DIST_SCHEDULE
);
2521 OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
2522 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2527 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_ASYNC
);
2528 if (clauses
->async_expr
)
2529 OMP_CLAUSE_ASYNC_EXPR (c
)
2530 = gfc_convert_expr_to_tree (block
, clauses
->async_expr
);
2532 OMP_CLAUSE_ASYNC_EXPR (c
) = NULL
;
2533 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2537 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_SEQ
);
2538 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2540 if (clauses
->par_auto
)
2542 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_AUTO
);
2543 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2545 if (clauses
->independent
)
2547 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_INDEPENDENT
);
2548 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2550 if (clauses
->wait_list
)
2554 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
2556 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WAIT
);
2557 OMP_CLAUSE_DECL (c
) = gfc_convert_expr_to_tree (block
, el
->expr
);
2558 OMP_CLAUSE_CHAIN (c
) = omp_clauses
;
2562 if (clauses
->num_gangs_expr
)
2565 = gfc_convert_expr_to_tree (block
, clauses
->num_gangs_expr
);
2566 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_GANGS
);
2567 OMP_CLAUSE_NUM_GANGS_EXPR (c
) = num_gangs_var
;
2568 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2570 if (clauses
->num_workers_expr
)
2572 tree num_workers_var
2573 = gfc_convert_expr_to_tree (block
, clauses
->num_workers_expr
);
2574 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_NUM_WORKERS
);
2575 OMP_CLAUSE_NUM_WORKERS_EXPR (c
) = num_workers_var
;
2576 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2578 if (clauses
->vector_length_expr
)
2580 tree vector_length_var
2581 = gfc_convert_expr_to_tree (block
, clauses
->vector_length_expr
);
2582 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR_LENGTH
);
2583 OMP_CLAUSE_VECTOR_LENGTH_EXPR (c
) = vector_length_var
;
2584 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2586 if (clauses
->tile_list
)
2588 vec
<tree
, va_gc
> *tvec
;
2591 vec_alloc (tvec
, 4);
2593 for (el
= clauses
->tile_list
; el
; el
= el
->next
)
2594 vec_safe_push (tvec
, gfc_convert_expr_to_tree (block
, el
->expr
));
2596 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_TILE
);
2597 OMP_CLAUSE_TILE_LIST (c
) = build_tree_list_vec (tvec
);
2598 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2601 if (clauses
->vector
)
2603 if (clauses
->vector_expr
)
2606 = gfc_convert_expr_to_tree (block
, clauses
->vector_expr
);
2607 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR
);
2608 OMP_CLAUSE_VECTOR_EXPR (c
) = vector_var
;
2609 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2613 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_VECTOR
);
2614 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2617 if (clauses
->worker
)
2619 if (clauses
->worker_expr
)
2622 = gfc_convert_expr_to_tree (block
, clauses
->worker_expr
);
2623 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WORKER
);
2624 OMP_CLAUSE_WORKER_EXPR (c
) = worker_var
;
2625 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2629 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_WORKER
);
2630 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2636 c
= build_omp_clause (where
.lb
->location
, OMP_CLAUSE_GANG
);
2637 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
2638 if (clauses
->gang_num_expr
)
2640 arg
= gfc_convert_expr_to_tree (block
, clauses
->gang_num_expr
);
2641 OMP_CLAUSE_GANG_EXPR (c
) = arg
;
2643 if (clauses
->gang_static
)
2645 arg
= clauses
->gang_static_expr
2646 ? gfc_convert_expr_to_tree (block
, clauses
->gang_static_expr
)
2647 : integer_minus_one_node
;
2648 OMP_CLAUSE_GANG_STATIC_EXPR (c
) = arg
;
2652 return nreverse (omp_clauses
);
2655 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
2658 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
2663 stmt
= gfc_trans_code (code
);
2664 if (TREE_CODE (stmt
) != BIND_EXPR
)
2666 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
2668 tree block
= poplevel (1, 0);
2669 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
2679 /* Trans OpenACC directives. */
2680 /* parallel, kernels, data and host_data. */
2682 gfc_trans_oacc_construct (gfc_code
*code
)
2685 tree stmt
, oacc_clauses
;
2686 enum tree_code construct_code
;
2690 case EXEC_OACC_PARALLEL
:
2691 construct_code
= OACC_PARALLEL
;
2693 case EXEC_OACC_KERNELS
:
2694 construct_code
= OACC_KERNELS
;
2696 case EXEC_OACC_DATA
:
2697 construct_code
= OACC_DATA
;
2699 case EXEC_OACC_HOST_DATA
:
2700 construct_code
= OACC_HOST_DATA
;
2706 gfc_start_block (&block
);
2707 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
2709 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
2710 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
2712 gfc_add_expr_to_block (&block
, stmt
);
2713 return gfc_finish_block (&block
);
2716 /* update, enter_data, exit_data, cache. */
2718 gfc_trans_oacc_executable_directive (gfc_code
*code
)
2721 tree stmt
, oacc_clauses
;
2722 enum tree_code construct_code
;
2726 case EXEC_OACC_UPDATE
:
2727 construct_code
= OACC_UPDATE
;
2729 case EXEC_OACC_ENTER_DATA
:
2730 construct_code
= OACC_ENTER_DATA
;
2732 case EXEC_OACC_EXIT_DATA
:
2733 construct_code
= OACC_EXIT_DATA
;
2735 case EXEC_OACC_CACHE
:
2736 construct_code
= OACC_CACHE
;
2742 gfc_start_block (&block
);
2743 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
2745 stmt
= build1_loc (input_location
, construct_code
, void_type_node
,
2747 gfc_add_expr_to_block (&block
, stmt
);
2748 return gfc_finish_block (&block
);
2752 gfc_trans_oacc_wait_directive (gfc_code
*code
)
2756 vec
<tree
, va_gc
> *args
;
2759 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
2760 location_t loc
= input_location
;
2762 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
2765 vec_alloc (args
, nparms
+ 2);
2766 stmt
= builtin_decl_explicit (BUILT_IN_GOACC_WAIT
);
2768 gfc_start_block (&block
);
2770 if (clauses
->async_expr
)
2771 t
= gfc_convert_expr_to_tree (&block
, clauses
->async_expr
);
2773 t
= build_int_cst (integer_type_node
, -2);
2775 args
->quick_push (t
);
2776 args
->quick_push (build_int_cst (integer_type_node
, nparms
));
2778 for (el
= clauses
->wait_list
; el
; el
= el
->next
)
2779 args
->quick_push (gfc_convert_expr_to_tree (&block
, el
->expr
));
2781 stmt
= build_call_expr_loc_vec (loc
, stmt
, args
);
2782 gfc_add_expr_to_block (&block
, stmt
);
2786 return gfc_finish_block (&block
);
2789 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
2790 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
2793 gfc_trans_omp_atomic (gfc_code
*code
)
2795 gfc_code
*atomic_code
= code
;
2799 gfc_expr
*expr2
, *e
;
2802 tree lhsaddr
, type
, rhs
, x
;
2803 enum tree_code op
= ERROR_MARK
;
2804 enum tree_code aop
= OMP_ATOMIC
;
2805 bool var_on_left
= false;
2806 bool seq_cst
= (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SEQ_CST
) != 0;
2808 code
= code
->block
->next
;
2809 gcc_assert (code
->op
== EXEC_ASSIGN
);
2810 var
= code
->expr1
->symtree
->n
.sym
;
2812 gfc_init_se (&lse
, NULL
);
2813 gfc_init_se (&rse
, NULL
);
2814 gfc_init_se (&vse
, NULL
);
2815 gfc_start_block (&block
);
2817 expr2
= code
->expr2
;
2818 if (expr2
->expr_type
== EXPR_FUNCTION
2819 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2820 expr2
= expr2
->value
.function
.actual
->expr
;
2822 switch (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
2824 case GFC_OMP_ATOMIC_READ
:
2825 gfc_conv_expr (&vse
, code
->expr1
);
2826 gfc_add_block_to_block (&block
, &vse
.pre
);
2828 gfc_conv_expr (&lse
, expr2
);
2829 gfc_add_block_to_block (&block
, &lse
.pre
);
2830 type
= TREE_TYPE (lse
.expr
);
2831 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
2833 x
= build1 (OMP_ATOMIC_READ
, type
, lhsaddr
);
2834 OMP_ATOMIC_SEQ_CST (x
) = seq_cst
;
2835 x
= convert (TREE_TYPE (vse
.expr
), x
);
2836 gfc_add_modify (&block
, vse
.expr
, x
);
2838 gfc_add_block_to_block (&block
, &lse
.pre
);
2839 gfc_add_block_to_block (&block
, &rse
.pre
);
2841 return gfc_finish_block (&block
);
2842 case GFC_OMP_ATOMIC_CAPTURE
:
2843 aop
= OMP_ATOMIC_CAPTURE_NEW
;
2844 if (expr2
->expr_type
== EXPR_VARIABLE
)
2846 aop
= OMP_ATOMIC_CAPTURE_OLD
;
2847 gfc_conv_expr (&vse
, code
->expr1
);
2848 gfc_add_block_to_block (&block
, &vse
.pre
);
2850 gfc_conv_expr (&lse
, expr2
);
2851 gfc_add_block_to_block (&block
, &lse
.pre
);
2852 gfc_init_se (&lse
, NULL
);
2854 var
= code
->expr1
->symtree
->n
.sym
;
2855 expr2
= code
->expr2
;
2856 if (expr2
->expr_type
== EXPR_FUNCTION
2857 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2858 expr2
= expr2
->value
.function
.actual
->expr
;
2865 gfc_conv_expr (&lse
, code
->expr1
);
2866 gfc_add_block_to_block (&block
, &lse
.pre
);
2867 type
= TREE_TYPE (lse
.expr
);
2868 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
2870 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
2871 == GFC_OMP_ATOMIC_WRITE
)
2872 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
2874 gfc_conv_expr (&rse
, expr2
);
2875 gfc_add_block_to_block (&block
, &rse
.pre
);
2877 else if (expr2
->expr_type
== EXPR_OP
)
2880 switch (expr2
->value
.op
.op
)
2882 case INTRINSIC_PLUS
:
2885 case INTRINSIC_TIMES
:
2888 case INTRINSIC_MINUS
:
2891 case INTRINSIC_DIVIDE
:
2892 if (expr2
->ts
.type
== BT_INTEGER
)
2893 op
= TRUNC_DIV_EXPR
;
2898 op
= TRUTH_ANDIF_EXPR
;
2901 op
= TRUTH_ORIF_EXPR
;
2906 case INTRINSIC_NEQV
:
2912 e
= expr2
->value
.op
.op1
;
2913 if (e
->expr_type
== EXPR_FUNCTION
2914 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2915 e
= e
->value
.function
.actual
->expr
;
2916 if (e
->expr_type
== EXPR_VARIABLE
2917 && e
->symtree
!= NULL
2918 && e
->symtree
->n
.sym
== var
)
2920 expr2
= expr2
->value
.op
.op2
;
2925 e
= expr2
->value
.op
.op2
;
2926 if (e
->expr_type
== EXPR_FUNCTION
2927 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2928 e
= e
->value
.function
.actual
->expr
;
2929 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2930 && e
->symtree
!= NULL
2931 && e
->symtree
->n
.sym
== var
);
2932 expr2
= expr2
->value
.op
.op1
;
2933 var_on_left
= false;
2935 gfc_conv_expr (&rse
, expr2
);
2936 gfc_add_block_to_block (&block
, &rse
.pre
);
2940 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
2941 switch (expr2
->value
.function
.isym
->id
)
2961 e
= expr2
->value
.function
.actual
->expr
;
2962 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2963 && e
->symtree
!= NULL
2964 && e
->symtree
->n
.sym
== var
);
2966 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
2967 gfc_add_block_to_block (&block
, &rse
.pre
);
2968 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
2970 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
2971 gfc_actual_arglist
*arg
;
2973 gfc_add_modify (&block
, accum
, rse
.expr
);
2974 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
2977 gfc_init_block (&rse
.pre
);
2978 gfc_conv_expr (&rse
, arg
->expr
);
2979 gfc_add_block_to_block (&block
, &rse
.pre
);
2980 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (accum
),
2982 gfc_add_modify (&block
, accum
, x
);
2988 expr2
= expr2
->value
.function
.actual
->next
->expr
;
2991 lhsaddr
= save_expr (lhsaddr
);
2992 if (TREE_CODE (lhsaddr
) != SAVE_EXPR
2993 && (TREE_CODE (lhsaddr
) != ADDR_EXPR
2994 || TREE_CODE (TREE_OPERAND (lhsaddr
, 0)) != VAR_DECL
))
2996 /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
2997 it even after unsharing function body. */
2998 tree var
= create_tmp_var_raw (TREE_TYPE (lhsaddr
));
2999 DECL_CONTEXT (var
) = current_function_decl
;
3000 lhsaddr
= build4 (TARGET_EXPR
, TREE_TYPE (lhsaddr
), var
, lhsaddr
,
3001 NULL_TREE
, NULL_TREE
);
3004 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
3006 if (((atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3007 == GFC_OMP_ATOMIC_WRITE
)
3008 || (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_SWAP
))
3012 x
= convert (TREE_TYPE (rhs
),
3013 build_fold_indirect_ref_loc (input_location
, lhsaddr
));
3015 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), x
, rhs
);
3017 x
= fold_build2_loc (input_location
, op
, TREE_TYPE (rhs
), rhs
, x
);
3020 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
3021 && TREE_CODE (type
) != COMPLEX_TYPE
)
3022 x
= fold_build1_loc (input_location
, REALPART_EXPR
,
3023 TREE_TYPE (TREE_TYPE (rhs
)), x
);
3025 gfc_add_block_to_block (&block
, &lse
.pre
);
3026 gfc_add_block_to_block (&block
, &rse
.pre
);
3028 if (aop
== OMP_ATOMIC
)
3030 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
3031 OMP_ATOMIC_SEQ_CST (x
) = seq_cst
;
3032 gfc_add_expr_to_block (&block
, x
);
3036 if (aop
== OMP_ATOMIC_CAPTURE_NEW
)
3039 expr2
= code
->expr2
;
3040 if (expr2
->expr_type
== EXPR_FUNCTION
3041 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
3042 expr2
= expr2
->value
.function
.actual
->expr
;
3044 gcc_assert (expr2
->expr_type
== EXPR_VARIABLE
);
3045 gfc_conv_expr (&vse
, code
->expr1
);
3046 gfc_add_block_to_block (&block
, &vse
.pre
);
3048 gfc_init_se (&lse
, NULL
);
3049 gfc_conv_expr (&lse
, expr2
);
3050 gfc_add_block_to_block (&block
, &lse
.pre
);
3052 x
= build2 (aop
, type
, lhsaddr
, convert (type
, x
));
3053 OMP_ATOMIC_SEQ_CST (x
) = seq_cst
;
3054 x
= convert (TREE_TYPE (vse
.expr
), x
);
3055 gfc_add_modify (&block
, vse
.expr
, x
);
3058 return gfc_finish_block (&block
);
3062 gfc_trans_omp_barrier (void)
3064 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_BARRIER
);
3065 return build_call_expr_loc (input_location
, decl
, 0);
3069 gfc_trans_omp_cancel (gfc_code
*code
)
3072 tree ifc
= boolean_true_node
;
3074 switch (code
->ext
.omp_clauses
->cancel
)
3076 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
3077 case OMP_CANCEL_DO
: mask
= 2; break;
3078 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
3079 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
3080 default: gcc_unreachable ();
3082 gfc_start_block (&block
);
3083 if (code
->ext
.omp_clauses
->if_expr
)
3088 gfc_init_se (&se
, NULL
);
3089 gfc_conv_expr (&se
, code
->ext
.omp_clauses
->if_expr
);
3090 gfc_add_block_to_block (&block
, &se
.pre
);
3091 if_var
= gfc_evaluate_now (se
.expr
, &block
);
3092 gfc_add_block_to_block (&block
, &se
.post
);
3093 tree type
= TREE_TYPE (if_var
);
3094 ifc
= fold_build2_loc (input_location
, NE_EXPR
,
3095 boolean_type_node
, if_var
,
3096 build_zero_cst (type
));
3098 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCEL
);
3099 tree c_bool_type
= TREE_TYPE (TREE_TYPE (decl
));
3100 ifc
= fold_convert (c_bool_type
, ifc
);
3101 gfc_add_expr_to_block (&block
,
3102 build_call_expr_loc (input_location
, decl
, 2,
3103 build_int_cst (integer_type_node
,
3105 return gfc_finish_block (&block
);
3109 gfc_trans_omp_cancellation_point (gfc_code
*code
)
3112 switch (code
->ext
.omp_clauses
->cancel
)
3114 case OMP_CANCEL_PARALLEL
: mask
= 1; break;
3115 case OMP_CANCEL_DO
: mask
= 2; break;
3116 case OMP_CANCEL_SECTIONS
: mask
= 4; break;
3117 case OMP_CANCEL_TASKGROUP
: mask
= 8; break;
3118 default: gcc_unreachable ();
3120 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT
);
3121 return build_call_expr_loc (input_location
, decl
, 1,
3122 build_int_cst (integer_type_node
, mask
));
3126 gfc_trans_omp_critical (gfc_code
*code
)
3128 tree name
= NULL_TREE
, stmt
;
3129 if (code
->ext
.omp_name
!= NULL
)
3130 name
= get_identifier (code
->ext
.omp_name
);
3131 stmt
= gfc_trans_code (code
->block
->next
);
3132 return build3_loc (input_location
, OMP_CRITICAL
, void_type_node
, stmt
,
3136 typedef struct dovar_init_d
{
3143 gfc_trans_omp_do (gfc_code
*code
, gfc_exec_op op
, stmtblock_t
*pblock
,
3144 gfc_omp_clauses
*do_clauses
, tree par_clauses
)
3147 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
;
3148 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
3151 gfc_omp_clauses
*clauses
= code
->ext
.omp_clauses
;
3152 int i
, collapse
= clauses
->collapse
;
3153 vec
<dovar_init
> inits
= vNULL
;
3160 code
= code
->block
->next
;
3161 gcc_assert (code
->op
== EXEC_DO
);
3163 init
= make_tree_vec (collapse
);
3164 cond
= make_tree_vec (collapse
);
3165 incr
= make_tree_vec (collapse
);
3169 gfc_start_block (&block
);
3173 omp_clauses
= gfc_trans_omp_clauses (pblock
, do_clauses
, code
->loc
);
3175 for (i
= 0; i
< collapse
; i
++)
3178 int dovar_found
= 0;
3183 gfc_omp_namelist
*n
= NULL
;
3184 if (op
!= EXEC_OMP_DISTRIBUTE
)
3185 for (n
= clauses
->lists
[(op
== EXEC_OMP_SIMD
&& collapse
== 1)
3186 ? OMP_LIST_LINEAR
: OMP_LIST_LASTPRIVATE
];
3187 n
!= NULL
; n
= n
->next
)
3188 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
3192 else if (n
== NULL
&& op
!= EXEC_OMP_SIMD
)
3193 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
3194 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
3200 /* Evaluate all the expressions in the iterator. */
3201 gfc_init_se (&se
, NULL
);
3202 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
3203 gfc_add_block_to_block (pblock
, &se
.pre
);
3205 type
= TREE_TYPE (dovar
);
3206 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
3208 gfc_init_se (&se
, NULL
);
3209 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
3210 gfc_add_block_to_block (pblock
, &se
.pre
);
3211 from
= gfc_evaluate_now (se
.expr
, pblock
);
3213 gfc_init_se (&se
, NULL
);
3214 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
3215 gfc_add_block_to_block (pblock
, &se
.pre
);
3216 to
= gfc_evaluate_now (se
.expr
, pblock
);
3218 gfc_init_se (&se
, NULL
);
3219 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
3220 gfc_add_block_to_block (pblock
, &se
.pre
);
3221 step
= gfc_evaluate_now (se
.expr
, pblock
);
3224 /* Special case simple loops. */
3225 if (TREE_CODE (dovar
) == VAR_DECL
)
3227 if (integer_onep (step
))
3229 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
3234 = gfc_trans_omp_variable (code
->ext
.iterator
->var
->symtree
->n
.sym
,
3240 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, dovar
, from
);
3241 /* The condition should not be folded. */
3242 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, simple
> 0
3243 ? LE_EXPR
: GE_EXPR
,
3244 boolean_type_node
, dovar
, to
);
3245 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
3247 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
3250 TREE_VEC_ELT (incr
, i
));
3254 /* STEP is not 1 or -1. Use:
3255 for (count = 0; count < (to + step - from) / step; count++)
3257 dovar = from + count * step;
3261 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, step
, from
);
3262 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, to
, tmp
);
3263 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
, tmp
,
3265 tmp
= gfc_evaluate_now (tmp
, pblock
);
3266 count
= gfc_create_var (type
, "count");
3267 TREE_VEC_ELT (init
, i
) = build2_v (MODIFY_EXPR
, count
,
3268 build_int_cst (type
, 0));
3269 /* The condition should not be folded. */
3270 TREE_VEC_ELT (cond
, i
) = build2_loc (input_location
, LT_EXPR
,
3273 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
, PLUS_EXPR
,
3275 build_int_cst (type
, 1));
3276 TREE_VEC_ELT (incr
, i
) = fold_build2_loc (input_location
,
3277 MODIFY_EXPR
, type
, count
,
3278 TREE_VEC_ELT (incr
, i
));
3280 /* Initialize DOVAR. */
3281 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, count
, step
);
3282 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, from
, tmp
);
3283 dovar_init e
= {dovar
, tmp
};
3284 inits
.safe_push (e
);
3287 if (dovar_found
== 2
3288 && op
== EXEC_OMP_SIMD
3292 for (tmp
= omp_clauses
; tmp
; tmp
= OMP_CLAUSE_CHAIN (tmp
))
3293 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_LINEAR
3294 && OMP_CLAUSE_DECL (tmp
) == dovar
)
3296 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3302 if (op
== EXEC_OMP_SIMD
)
3306 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
3307 OMP_CLAUSE_LINEAR_STEP (tmp
) = step
;
3308 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3311 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
3316 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
3317 OMP_CLAUSE_DECL (tmp
) = dovar_decl
;
3318 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
3320 if (dovar_found
== 2)
3327 /* If dovar is lastprivate, but different counter is used,
3328 dovar += step needs to be added to
3329 OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
3330 will have the value on entry of the last loop, rather
3331 than value after iterator increment. */
3332 tmp
= gfc_evaluate_now (step
, pblock
);
3333 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, dovar
,
3335 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
,
3337 for (c
= omp_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
3338 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
3339 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3341 OMP_CLAUSE_LASTPRIVATE_STMT (c
) = tmp
;
3344 else if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LINEAR
3345 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3347 OMP_CLAUSE_LINEAR_STMT (c
) = tmp
;
3351 if (c
== NULL
&& op
== EXEC_OMP_DO
&& par_clauses
!= NULL
)
3353 for (c
= par_clauses
; c
; c
= OMP_CLAUSE_CHAIN (c
))
3354 if (OMP_CLAUSE_CODE (c
) == OMP_CLAUSE_LASTPRIVATE
3355 && OMP_CLAUSE_DECL (c
) == dovar_decl
)
3357 tree l
= build_omp_clause (input_location
,
3358 OMP_CLAUSE_LASTPRIVATE
);
3359 OMP_CLAUSE_DECL (l
) = dovar_decl
;
3360 OMP_CLAUSE_CHAIN (l
) = omp_clauses
;
3361 OMP_CLAUSE_LASTPRIVATE_STMT (l
) = tmp
;
3363 OMP_CLAUSE_SET_CODE (c
, OMP_CLAUSE_SHARED
);
3367 gcc_assert (simple
|| c
!= NULL
);
3371 if (op
!= EXEC_OMP_SIMD
)
3372 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_PRIVATE
);
3373 else if (collapse
== 1)
3375 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LINEAR
);
3376 OMP_CLAUSE_LINEAR_STEP (tmp
) = build_int_cst (type
, 1);
3377 OMP_CLAUSE_LINEAR_NO_COPYIN (tmp
) = 1;
3378 OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp
) = 1;
3381 tmp
= build_omp_clause (input_location
, OMP_CLAUSE_LASTPRIVATE
);
3382 OMP_CLAUSE_DECL (tmp
) = count
;
3383 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
3386 if (i
+ 1 < collapse
)
3387 code
= code
->block
->next
;
3390 if (pblock
!= &block
)
3393 gfc_start_block (&block
);
3396 gfc_start_block (&body
);
3398 FOR_EACH_VEC_ELT (inits
, ix
, di
)
3399 gfc_add_modify (&body
, di
->var
, di
->init
);
3402 /* Cycle statement is implemented with a goto. Exit statement must not be
3403 present for this loop. */
3404 cycle_label
= gfc_build_label_decl (NULL_TREE
);
3406 /* Put these labels where they can be found later. */
3408 code
->cycle_label
= cycle_label
;
3409 code
->exit_label
= NULL_TREE
;
3411 /* Main loop body. */
3412 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
3413 gfc_add_expr_to_block (&body
, tmp
);
3415 /* Label for cycle statements (if needed). */
3416 if (TREE_USED (cycle_label
))
3418 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
3419 gfc_add_expr_to_block (&body
, tmp
);
3422 /* End of loop body. */
3425 case EXEC_OMP_SIMD
: stmt
= make_node (OMP_SIMD
); break;
3426 case EXEC_OMP_DO
: stmt
= make_node (OMP_FOR
); break;
3427 case EXEC_OMP_DISTRIBUTE
: stmt
= make_node (OMP_DISTRIBUTE
); break;
3428 case EXEC_OACC_LOOP
: stmt
= make_node (OACC_LOOP
); break;
3429 default: gcc_unreachable ();
3432 TREE_TYPE (stmt
) = void_type_node
;
3433 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
3434 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
3435 OMP_FOR_INIT (stmt
) = init
;
3436 OMP_FOR_COND (stmt
) = cond
;
3437 OMP_FOR_INCR (stmt
) = incr
;
3438 gfc_add_expr_to_block (&block
, stmt
);
3440 return gfc_finish_block (&block
);
3443 /* parallel loop and kernels loop. */
3445 gfc_trans_oacc_combined_directive (gfc_code
*code
)
3447 stmtblock_t block
, *pblock
= NULL
;
3448 gfc_omp_clauses construct_clauses
, loop_clauses
;
3449 tree stmt
, oacc_clauses
= NULL_TREE
;
3450 enum tree_code construct_code
;
3454 case EXEC_OACC_PARALLEL_LOOP
:
3455 construct_code
= OACC_PARALLEL
;
3457 case EXEC_OACC_KERNELS_LOOP
:
3458 construct_code
= OACC_KERNELS
;
3464 gfc_start_block (&block
);
3466 memset (&loop_clauses
, 0, sizeof (loop_clauses
));
3467 if (code
->ext
.omp_clauses
!= NULL
)
3469 memcpy (&construct_clauses
, code
->ext
.omp_clauses
,
3470 sizeof (construct_clauses
));
3471 loop_clauses
.collapse
= construct_clauses
.collapse
;
3472 loop_clauses
.gang
= construct_clauses
.gang
;
3473 loop_clauses
.gang_static
= construct_clauses
.gang_static
;
3474 loop_clauses
.gang_num_expr
= construct_clauses
.gang_num_expr
;
3475 loop_clauses
.gang_static_expr
= construct_clauses
.gang_static_expr
;
3476 loop_clauses
.vector
= construct_clauses
.vector
;
3477 loop_clauses
.vector_expr
= construct_clauses
.vector_expr
;
3478 loop_clauses
.worker
= construct_clauses
.worker
;
3479 loop_clauses
.worker_expr
= construct_clauses
.worker_expr
;
3480 loop_clauses
.seq
= construct_clauses
.seq
;
3481 loop_clauses
.par_auto
= construct_clauses
.par_auto
;
3482 loop_clauses
.independent
= construct_clauses
.independent
;
3483 loop_clauses
.tile_list
= construct_clauses
.tile_list
;
3484 loop_clauses
.lists
[OMP_LIST_PRIVATE
]
3485 = construct_clauses
.lists
[OMP_LIST_PRIVATE
];
3486 loop_clauses
.lists
[OMP_LIST_REDUCTION
]
3487 = construct_clauses
.lists
[OMP_LIST_REDUCTION
];
3488 construct_clauses
.gang
= false;
3489 construct_clauses
.gang_static
= false;
3490 construct_clauses
.gang_num_expr
= NULL
;
3491 construct_clauses
.gang_static_expr
= NULL
;
3492 construct_clauses
.vector
= false;
3493 construct_clauses
.vector_expr
= NULL
;
3494 construct_clauses
.worker
= false;
3495 construct_clauses
.worker_expr
= NULL
;
3496 construct_clauses
.seq
= false;
3497 construct_clauses
.par_auto
= false;
3498 construct_clauses
.independent
= false;
3499 construct_clauses
.independent
= false;
3500 construct_clauses
.tile_list
= NULL
;
3501 construct_clauses
.lists
[OMP_LIST_PRIVATE
] = NULL
;
3502 if (construct_code
== OACC_KERNELS
)
3503 construct_clauses
.lists
[OMP_LIST_REDUCTION
] = NULL
;
3504 oacc_clauses
= gfc_trans_omp_clauses (&block
, &construct_clauses
,
3507 if (!loop_clauses
.seq
)
3511 stmt
= gfc_trans_omp_do (code
, EXEC_OACC_LOOP
, pblock
, &loop_clauses
, NULL
);
3512 if (TREE_CODE (stmt
) != BIND_EXPR
)
3513 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3516 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
3518 gfc_add_expr_to_block (&block
, stmt
);
3519 return gfc_finish_block (&block
);
3523 gfc_trans_omp_flush (void)
3525 tree decl
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
3526 return build_call_expr_loc (input_location
, decl
, 0);
3530 gfc_trans_omp_master (gfc_code
*code
)
3532 tree stmt
= gfc_trans_code (code
->block
->next
);
3533 if (IS_EMPTY_STMT (stmt
))
3535 return build1_v (OMP_MASTER
, stmt
);
3539 gfc_trans_omp_ordered (gfc_code
*code
)
3541 return build2_loc (input_location
, OMP_ORDERED
, void_type_node
,
3542 gfc_trans_code (code
->block
->next
), NULL_TREE
);
3546 gfc_trans_omp_parallel (gfc_code
*code
)
3549 tree stmt
, omp_clauses
;
3551 gfc_start_block (&block
);
3552 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3554 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
3555 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
3557 gfc_add_expr_to_block (&block
, stmt
);
3558 return gfc_finish_block (&block
);
3565 GFC_OMP_SPLIT_PARALLEL
,
3566 GFC_OMP_SPLIT_DISTRIBUTE
,
3567 GFC_OMP_SPLIT_TEAMS
,
3568 GFC_OMP_SPLIT_TARGET
,
3574 GFC_OMP_MASK_SIMD
= (1 << GFC_OMP_SPLIT_SIMD
),
3575 GFC_OMP_MASK_DO
= (1 << GFC_OMP_SPLIT_DO
),
3576 GFC_OMP_MASK_PARALLEL
= (1 << GFC_OMP_SPLIT_PARALLEL
),
3577 GFC_OMP_MASK_DISTRIBUTE
= (1 << GFC_OMP_SPLIT_DISTRIBUTE
),
3578 GFC_OMP_MASK_TEAMS
= (1 << GFC_OMP_SPLIT_TEAMS
),
3579 GFC_OMP_MASK_TARGET
= (1 << GFC_OMP_SPLIT_TARGET
)
3583 gfc_split_omp_clauses (gfc_code
*code
,
3584 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
])
3586 int mask
= 0, innermost
= 0;
3587 memset (clausesa
, 0, GFC_OMP_SPLIT_NUM
* sizeof (gfc_omp_clauses
));
3590 case EXEC_OMP_DISTRIBUTE
:
3591 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
3593 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3594 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
3595 innermost
= GFC_OMP_SPLIT_DO
;
3597 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3598 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_PARALLEL
3599 | GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
3600 innermost
= GFC_OMP_SPLIT_SIMD
;
3602 case EXEC_OMP_DISTRIBUTE_SIMD
:
3603 mask
= GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
3604 innermost
= GFC_OMP_SPLIT_SIMD
;
3607 innermost
= GFC_OMP_SPLIT_DO
;
3609 case EXEC_OMP_DO_SIMD
:
3610 mask
= GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
3611 innermost
= GFC_OMP_SPLIT_SIMD
;
3613 case EXEC_OMP_PARALLEL
:
3614 innermost
= GFC_OMP_SPLIT_PARALLEL
;
3616 case EXEC_OMP_PARALLEL_DO
:
3617 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
3618 innermost
= GFC_OMP_SPLIT_DO
;
3620 case EXEC_OMP_PARALLEL_DO_SIMD
:
3621 mask
= GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
3622 innermost
= GFC_OMP_SPLIT_SIMD
;
3625 innermost
= GFC_OMP_SPLIT_SIMD
;
3627 case EXEC_OMP_TARGET
:
3628 innermost
= GFC_OMP_SPLIT_TARGET
;
3630 case EXEC_OMP_TARGET_TEAMS
:
3631 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
;
3632 innermost
= GFC_OMP_SPLIT_TEAMS
;
3634 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3635 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
3636 | GFC_OMP_MASK_DISTRIBUTE
;
3637 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
3639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3640 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
3641 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
3642 innermost
= GFC_OMP_SPLIT_DO
;
3644 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3645 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
3646 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
3647 innermost
= GFC_OMP_SPLIT_SIMD
;
3649 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3650 mask
= GFC_OMP_MASK_TARGET
| GFC_OMP_MASK_TEAMS
3651 | GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
3652 innermost
= GFC_OMP_SPLIT_SIMD
;
3654 case EXEC_OMP_TEAMS
:
3655 innermost
= GFC_OMP_SPLIT_TEAMS
;
3657 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3658 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
;
3659 innermost
= GFC_OMP_SPLIT_DISTRIBUTE
;
3661 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3662 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
3663 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
;
3664 innermost
= GFC_OMP_SPLIT_DO
;
3666 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3667 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
3668 | GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
| GFC_OMP_MASK_SIMD
;
3669 innermost
= GFC_OMP_SPLIT_SIMD
;
3671 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3672 mask
= GFC_OMP_MASK_TEAMS
| GFC_OMP_MASK_DISTRIBUTE
| GFC_OMP_MASK_SIMD
;
3673 innermost
= GFC_OMP_SPLIT_SIMD
;
3680 clausesa
[innermost
] = *code
->ext
.omp_clauses
;
3683 if (code
->ext
.omp_clauses
!= NULL
)
3685 if (mask
& GFC_OMP_MASK_TARGET
)
3687 /* First the clauses that are unique to some constructs. */
3688 clausesa
[GFC_OMP_SPLIT_TARGET
].lists
[OMP_LIST_MAP
]
3689 = code
->ext
.omp_clauses
->lists
[OMP_LIST_MAP
];
3690 clausesa
[GFC_OMP_SPLIT_TARGET
].device
3691 = code
->ext
.omp_clauses
->device
;
3693 if (mask
& GFC_OMP_MASK_TEAMS
)
3695 /* First the clauses that are unique to some constructs. */
3696 clausesa
[GFC_OMP_SPLIT_TEAMS
].num_teams
3697 = code
->ext
.omp_clauses
->num_teams
;
3698 clausesa
[GFC_OMP_SPLIT_TEAMS
].thread_limit
3699 = code
->ext
.omp_clauses
->thread_limit
;
3700 /* Shared and default clauses are allowed on parallel and teams. */
3701 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_SHARED
]
3702 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
3703 clausesa
[GFC_OMP_SPLIT_TEAMS
].default_sharing
3704 = code
->ext
.omp_clauses
->default_sharing
;
3706 if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
3708 /* First the clauses that are unique to some constructs. */
3709 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_sched_kind
3710 = code
->ext
.omp_clauses
->dist_sched_kind
;
3711 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].dist_chunk_size
3712 = code
->ext
.omp_clauses
->dist_chunk_size
;
3713 /* Duplicate collapse. */
3714 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].collapse
3715 = code
->ext
.omp_clauses
->collapse
;
3717 if (mask
& GFC_OMP_MASK_PARALLEL
)
3719 /* First the clauses that are unique to some constructs. */
3720 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_COPYIN
]
3721 = code
->ext
.omp_clauses
->lists
[OMP_LIST_COPYIN
];
3722 clausesa
[GFC_OMP_SPLIT_PARALLEL
].num_threads
3723 = code
->ext
.omp_clauses
->num_threads
;
3724 clausesa
[GFC_OMP_SPLIT_PARALLEL
].proc_bind
3725 = code
->ext
.omp_clauses
->proc_bind
;
3726 /* Shared and default clauses are allowed on parallel and teams. */
3727 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_SHARED
]
3728 = code
->ext
.omp_clauses
->lists
[OMP_LIST_SHARED
];
3729 clausesa
[GFC_OMP_SPLIT_PARALLEL
].default_sharing
3730 = code
->ext
.omp_clauses
->default_sharing
;
3732 if (mask
& GFC_OMP_MASK_DO
)
3734 /* First the clauses that are unique to some constructs. */
3735 clausesa
[GFC_OMP_SPLIT_DO
].ordered
3736 = code
->ext
.omp_clauses
->ordered
;
3737 clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
3738 = code
->ext
.omp_clauses
->sched_kind
;
3739 clausesa
[GFC_OMP_SPLIT_DO
].chunk_size
3740 = code
->ext
.omp_clauses
->chunk_size
;
3741 clausesa
[GFC_OMP_SPLIT_DO
].nowait
3742 = code
->ext
.omp_clauses
->nowait
;
3743 /* Duplicate collapse. */
3744 clausesa
[GFC_OMP_SPLIT_DO
].collapse
3745 = code
->ext
.omp_clauses
->collapse
;
3747 if (mask
& GFC_OMP_MASK_SIMD
)
3749 clausesa
[GFC_OMP_SPLIT_SIMD
].safelen_expr
3750 = code
->ext
.omp_clauses
->safelen_expr
;
3751 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LINEAR
]
3752 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LINEAR
];
3753 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_ALIGNED
]
3754 = code
->ext
.omp_clauses
->lists
[OMP_LIST_ALIGNED
];
3755 /* Duplicate collapse. */
3756 clausesa
[GFC_OMP_SPLIT_SIMD
].collapse
3757 = code
->ext
.omp_clauses
->collapse
;
3759 /* Private clause is supported on all constructs but target,
3760 it is enough to put it on the innermost one. For
3761 !$ omp do put it on parallel though,
3762 as that's what we did for OpenMP 3.1. */
3763 clausesa
[innermost
== GFC_OMP_SPLIT_DO
3764 ? (int) GFC_OMP_SPLIT_PARALLEL
3765 : innermost
].lists
[OMP_LIST_PRIVATE
]
3766 = code
->ext
.omp_clauses
->lists
[OMP_LIST_PRIVATE
];
3767 /* Firstprivate clause is supported on all constructs but
3768 target and simd. Put it on the outermost of those and
3769 duplicate on parallel. */
3770 if (mask
& GFC_OMP_MASK_TEAMS
)
3771 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_FIRSTPRIVATE
]
3772 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
3773 else if (mask
& GFC_OMP_MASK_DISTRIBUTE
)
3774 clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
].lists
[OMP_LIST_FIRSTPRIVATE
]
3775 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
3776 if (mask
& GFC_OMP_MASK_PARALLEL
)
3777 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_FIRSTPRIVATE
]
3778 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
3779 else if (mask
& GFC_OMP_MASK_DO
)
3780 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_FIRSTPRIVATE
]
3781 = code
->ext
.omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
];
3782 /* Lastprivate is allowed on do and simd. In
3783 parallel do{, simd} we actually want to put it on
3784 parallel rather than do. */
3785 if (mask
& GFC_OMP_MASK_PARALLEL
)
3786 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_LASTPRIVATE
]
3787 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
3788 else if (mask
& GFC_OMP_MASK_DO
)
3789 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_LASTPRIVATE
]
3790 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
3791 if (mask
& GFC_OMP_MASK_SIMD
)
3792 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_LASTPRIVATE
]
3793 = code
->ext
.omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
];
3794 /* Reduction is allowed on simd, do, parallel and teams.
3795 Duplicate it on all of them, but omit on do if
3796 parallel is present. */
3797 if (mask
& GFC_OMP_MASK_TEAMS
)
3798 clausesa
[GFC_OMP_SPLIT_TEAMS
].lists
[OMP_LIST_REDUCTION
]
3799 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
3800 if (mask
& GFC_OMP_MASK_PARALLEL
)
3801 clausesa
[GFC_OMP_SPLIT_PARALLEL
].lists
[OMP_LIST_REDUCTION
]
3802 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
3803 else if (mask
& GFC_OMP_MASK_DO
)
3804 clausesa
[GFC_OMP_SPLIT_DO
].lists
[OMP_LIST_REDUCTION
]
3805 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
3806 if (mask
& GFC_OMP_MASK_SIMD
)
3807 clausesa
[GFC_OMP_SPLIT_SIMD
].lists
[OMP_LIST_REDUCTION
]
3808 = code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION
];
3809 /* FIXME: This is currently being discussed. */
3810 if (mask
& GFC_OMP_MASK_PARALLEL
)
3811 clausesa
[GFC_OMP_SPLIT_PARALLEL
].if_expr
3812 = code
->ext
.omp_clauses
->if_expr
;
3814 clausesa
[GFC_OMP_SPLIT_TARGET
].if_expr
3815 = code
->ext
.omp_clauses
->if_expr
;
3817 if ((mask
& (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
3818 == (GFC_OMP_MASK_PARALLEL
| GFC_OMP_MASK_DO
))
3819 clausesa
[GFC_OMP_SPLIT_DO
].nowait
= true;
3823 gfc_trans_omp_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
3824 gfc_omp_clauses
*clausesa
, tree omp_clauses
)
3827 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
3828 tree stmt
, body
, omp_do_clauses
= NULL_TREE
;
3831 gfc_start_block (&block
);
3833 gfc_init_block (&block
);
3835 if (clausesa
== NULL
)
3837 clausesa
= clausesa_buf
;
3838 gfc_split_omp_clauses (code
, clausesa
);
3842 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DO
], code
->loc
);
3843 body
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, pblock
? pblock
: &block
,
3844 &clausesa
[GFC_OMP_SPLIT_SIMD
], omp_clauses
);
3847 if (TREE_CODE (body
) != BIND_EXPR
)
3848 body
= build3_v (BIND_EXPR
, NULL
, body
, poplevel (1, 0));
3852 else if (TREE_CODE (body
) != BIND_EXPR
)
3853 body
= build3_v (BIND_EXPR
, NULL
, body
, NULL_TREE
);
3856 stmt
= make_node (OMP_FOR
);
3857 TREE_TYPE (stmt
) = void_type_node
;
3858 OMP_FOR_BODY (stmt
) = body
;
3859 OMP_FOR_CLAUSES (stmt
) = omp_do_clauses
;
3863 gfc_add_expr_to_block (&block
, stmt
);
3864 return gfc_finish_block (&block
);
3868 gfc_trans_omp_parallel_do (gfc_code
*code
, stmtblock_t
*pblock
,
3869 gfc_omp_clauses
*clausesa
)
3871 stmtblock_t block
, *new_pblock
= pblock
;
3872 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
3873 tree stmt
, omp_clauses
= NULL_TREE
;
3876 gfc_start_block (&block
);
3878 gfc_init_block (&block
);
3880 if (clausesa
== NULL
)
3882 clausesa
= clausesa_buf
;
3883 gfc_split_omp_clauses (code
, clausesa
);
3886 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
3890 if (!clausesa
[GFC_OMP_SPLIT_DO
].ordered
3891 && clausesa
[GFC_OMP_SPLIT_DO
].sched_kind
!= OMP_SCHED_STATIC
)
3892 new_pblock
= &block
;
3896 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DO
, new_pblock
,
3897 &clausesa
[GFC_OMP_SPLIT_DO
], omp_clauses
);
3900 if (TREE_CODE (stmt
) != BIND_EXPR
)
3901 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3905 else if (TREE_CODE (stmt
) != BIND_EXPR
)
3906 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
3907 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
3909 OMP_PARALLEL_COMBINED (stmt
) = 1;
3910 gfc_add_expr_to_block (&block
, stmt
);
3911 return gfc_finish_block (&block
);
3915 gfc_trans_omp_parallel_do_simd (gfc_code
*code
, stmtblock_t
*pblock
,
3916 gfc_omp_clauses
*clausesa
)
3919 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
3920 tree stmt
, omp_clauses
= NULL_TREE
;
3923 gfc_start_block (&block
);
3925 gfc_init_block (&block
);
3927 if (clausesa
== NULL
)
3929 clausesa
= clausesa_buf
;
3930 gfc_split_omp_clauses (code
, clausesa
);
3934 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_PARALLEL
],
3938 stmt
= gfc_trans_omp_do_simd (code
, pblock
, clausesa
, omp_clauses
);
3941 if (TREE_CODE (stmt
) != BIND_EXPR
)
3942 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3946 else if (TREE_CODE (stmt
) != BIND_EXPR
)
3947 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, NULL_TREE
);
3950 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
3952 OMP_PARALLEL_COMBINED (stmt
) = 1;
3954 gfc_add_expr_to_block (&block
, stmt
);
3955 return gfc_finish_block (&block
);
3959 gfc_trans_omp_parallel_sections (gfc_code
*code
)
3962 gfc_omp_clauses section_clauses
;
3963 tree stmt
, omp_clauses
;
3965 memset (§ion_clauses
, 0, sizeof (section_clauses
));
3966 section_clauses
.nowait
= true;
3968 gfc_start_block (&block
);
3969 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3972 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
3973 if (TREE_CODE (stmt
) != BIND_EXPR
)
3974 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
3977 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
3979 OMP_PARALLEL_COMBINED (stmt
) = 1;
3980 gfc_add_expr_to_block (&block
, stmt
);
3981 return gfc_finish_block (&block
);
3985 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
3988 gfc_omp_clauses workshare_clauses
;
3989 tree stmt
, omp_clauses
;
3991 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
3992 workshare_clauses
.nowait
= true;
3994 gfc_start_block (&block
);
3995 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
3998 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
3999 if (TREE_CODE (stmt
) != BIND_EXPR
)
4000 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4003 stmt
= build2_loc (input_location
, OMP_PARALLEL
, void_type_node
, stmt
,
4005 OMP_PARALLEL_COMBINED (stmt
) = 1;
4006 gfc_add_expr_to_block (&block
, stmt
);
4007 return gfc_finish_block (&block
);
4011 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4013 stmtblock_t block
, body
;
4014 tree omp_clauses
, stmt
;
4015 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
4017 gfc_start_block (&block
);
4019 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
4021 gfc_init_block (&body
);
4022 for (code
= code
->block
; code
; code
= code
->block
)
4024 /* Last section is special because of lastprivate, so even if it
4025 is empty, chain it in. */
4026 stmt
= gfc_trans_omp_code (code
->next
,
4027 has_lastprivate
&& code
->block
== NULL
);
4028 if (! IS_EMPTY_STMT (stmt
))
4030 stmt
= build1_v (OMP_SECTION
, stmt
);
4031 gfc_add_expr_to_block (&body
, stmt
);
4034 stmt
= gfc_finish_block (&body
);
4036 stmt
= build2_loc (input_location
, OMP_SECTIONS
, void_type_node
, stmt
,
4038 gfc_add_expr_to_block (&block
, stmt
);
4040 return gfc_finish_block (&block
);
4044 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4046 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
4047 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4048 stmt
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, stmt
,
4054 gfc_trans_omp_task (gfc_code
*code
)
4057 tree stmt
, omp_clauses
;
4059 gfc_start_block (&block
);
4060 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4062 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4063 stmt
= build2_loc (input_location
, OMP_TASK
, void_type_node
, stmt
,
4065 gfc_add_expr_to_block (&block
, stmt
);
4066 return gfc_finish_block (&block
);
4070 gfc_trans_omp_taskgroup (gfc_code
*code
)
4072 tree stmt
= gfc_trans_code (code
->block
->next
);
4073 return build1_loc (input_location
, OMP_TASKGROUP
, void_type_node
, stmt
);
4077 gfc_trans_omp_taskwait (void)
4079 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT
);
4080 return build_call_expr_loc (input_location
, decl
, 0);
4084 gfc_trans_omp_taskyield (void)
4086 tree decl
= builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD
);
4087 return build_call_expr_loc (input_location
, decl
, 0);
4091 gfc_trans_omp_distribute (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
4094 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4095 tree stmt
, omp_clauses
= NULL_TREE
;
4097 gfc_start_block (&block
);
4098 if (clausesa
== NULL
)
4100 clausesa
= clausesa_buf
;
4101 gfc_split_omp_clauses (code
, clausesa
);
4105 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
4109 case EXEC_OMP_DISTRIBUTE
:
4110 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4111 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4112 /* This is handled in gfc_trans_omp_do. */
4115 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4116 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4117 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4118 stmt
= gfc_trans_omp_parallel_do (code
, &block
, clausesa
);
4119 if (TREE_CODE (stmt
) != BIND_EXPR
)
4120 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4124 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4125 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4126 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4127 stmt
= gfc_trans_omp_parallel_do_simd (code
, &block
, clausesa
);
4128 if (TREE_CODE (stmt
) != BIND_EXPR
)
4129 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4133 case EXEC_OMP_DISTRIBUTE_SIMD
:
4134 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4135 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4136 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_SIMD
, &block
,
4137 &clausesa
[GFC_OMP_SPLIT_SIMD
], NULL_TREE
);
4138 if (TREE_CODE (stmt
) != BIND_EXPR
)
4139 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4148 tree distribute
= make_node (OMP_DISTRIBUTE
);
4149 TREE_TYPE (distribute
) = void_type_node
;
4150 OMP_FOR_BODY (distribute
) = stmt
;
4151 OMP_FOR_CLAUSES (distribute
) = omp_clauses
;
4154 gfc_add_expr_to_block (&block
, stmt
);
4155 return gfc_finish_block (&block
);
4159 gfc_trans_omp_teams (gfc_code
*code
, gfc_omp_clauses
*clausesa
)
4162 gfc_omp_clauses clausesa_buf
[GFC_OMP_SPLIT_NUM
];
4163 tree stmt
, omp_clauses
= NULL_TREE
;
4164 bool combined
= true;
4166 gfc_start_block (&block
);
4167 if (clausesa
== NULL
)
4169 clausesa
= clausesa_buf
;
4170 gfc_split_omp_clauses (code
, clausesa
);
4174 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TEAMS
],
4178 case EXEC_OMP_TARGET_TEAMS
:
4179 case EXEC_OMP_TEAMS
:
4180 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4183 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4184 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4185 stmt
= gfc_trans_omp_do (code
, EXEC_OMP_DISTRIBUTE
, NULL
,
4186 &clausesa
[GFC_OMP_SPLIT_DISTRIBUTE
],
4190 stmt
= gfc_trans_omp_distribute (code
, clausesa
);
4193 stmt
= build2_loc (input_location
, OMP_TEAMS
, void_type_node
, stmt
,
4196 OMP_TEAMS_COMBINED (stmt
) = 1;
4197 gfc_add_expr_to_block (&block
, stmt
);
4198 return gfc_finish_block (&block
);
4202 gfc_trans_omp_target (gfc_code
*code
)
4205 gfc_omp_clauses clausesa
[GFC_OMP_SPLIT_NUM
];
4206 tree stmt
, omp_clauses
= NULL_TREE
;
4208 gfc_start_block (&block
);
4209 gfc_split_omp_clauses (code
, clausesa
);
4212 = gfc_trans_omp_clauses (&block
, &clausesa
[GFC_OMP_SPLIT_TARGET
],
4214 if (code
->op
== EXEC_OMP_TARGET
)
4215 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4219 stmt
= gfc_trans_omp_teams (code
, clausesa
);
4220 if (TREE_CODE (stmt
) != BIND_EXPR
)
4221 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0));
4226 stmt
= build2_loc (input_location
, OMP_TARGET
, void_type_node
, stmt
,
4228 gfc_add_expr_to_block (&block
, stmt
);
4229 return gfc_finish_block (&block
);
4233 gfc_trans_omp_target_data (gfc_code
*code
)
4236 tree stmt
, omp_clauses
;
4238 gfc_start_block (&block
);
4239 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4241 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4242 stmt
= build2_loc (input_location
, OMP_TARGET_DATA
, void_type_node
, stmt
,
4244 gfc_add_expr_to_block (&block
, stmt
);
4245 return gfc_finish_block (&block
);
4249 gfc_trans_omp_target_update (gfc_code
*code
)
4252 tree stmt
, omp_clauses
;
4254 gfc_start_block (&block
);
4255 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
4257 stmt
= build1_loc (input_location
, OMP_TARGET_UPDATE
, void_type_node
,
4259 gfc_add_expr_to_block (&block
, stmt
);
4260 return gfc_finish_block (&block
);
4264 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
4266 tree res
, tmp
, stmt
;
4267 stmtblock_t block
, *pblock
= NULL
;
4268 stmtblock_t singleblock
;
4269 int saved_ompws_flags
;
4270 bool singleblock_in_progress
= false;
4271 /* True if previous gfc_code in workshare construct is not workshared. */
4272 bool prev_singleunit
;
4274 code
= code
->block
->next
;
4278 gfc_start_block (&block
);
4281 ompws_flags
= OMPWS_WORKSHARE_FLAG
;
4282 prev_singleunit
= false;
4284 /* Translate statements one by one to trees until we reach
4285 the end of the workshare construct. Adjacent gfc_codes that
4286 are a single unit of work are clustered and encapsulated in a
4287 single OMP_SINGLE construct. */
4288 for (; code
; code
= code
->next
)
4290 if (code
->here
!= 0)
4292 res
= gfc_trans_label_here (code
);
4293 gfc_add_expr_to_block (pblock
, res
);
4296 /* No dependence analysis, use for clauses with wait.
4297 If this is the last gfc_code, use default omp_clauses. */
4298 if (code
->next
== NULL
&& clauses
->nowait
)
4299 ompws_flags
|= OMPWS_NOWAIT
;
4301 /* By default, every gfc_code is a single unit of work. */
4302 ompws_flags
|= OMPWS_CURR_SINGLEUNIT
;
4303 ompws_flags
&= ~(OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
);
4312 res
= gfc_trans_assign (code
);
4315 case EXEC_POINTER_ASSIGN
:
4316 res
= gfc_trans_pointer_assign (code
);
4319 case EXEC_INIT_ASSIGN
:
4320 res
= gfc_trans_init_assign (code
);
4324 res
= gfc_trans_forall (code
);
4328 res
= gfc_trans_where (code
);
4331 case EXEC_OMP_ATOMIC
:
4332 res
= gfc_trans_omp_directive (code
);
4335 case EXEC_OMP_PARALLEL
:
4336 case EXEC_OMP_PARALLEL_DO
:
4337 case EXEC_OMP_PARALLEL_SECTIONS
:
4338 case EXEC_OMP_PARALLEL_WORKSHARE
:
4339 case EXEC_OMP_CRITICAL
:
4340 saved_ompws_flags
= ompws_flags
;
4342 res
= gfc_trans_omp_directive (code
);
4343 ompws_flags
= saved_ompws_flags
;
4347 gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
4350 gfc_set_backend_locus (&code
->loc
);
4352 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
4354 if (prev_singleunit
)
4356 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
4357 /* Add current gfc_code to single block. */
4358 gfc_add_expr_to_block (&singleblock
, res
);
4361 /* Finish single block and add it to pblock. */
4362 tmp
= gfc_finish_block (&singleblock
);
4363 tmp
= build2_loc (input_location
, OMP_SINGLE
,
4364 void_type_node
, tmp
, NULL_TREE
);
4365 gfc_add_expr_to_block (pblock
, tmp
);
4366 /* Add current gfc_code to pblock. */
4367 gfc_add_expr_to_block (pblock
, res
);
4368 singleblock_in_progress
= false;
4373 if (ompws_flags
& OMPWS_CURR_SINGLEUNIT
)
4375 /* Start single block. */
4376 gfc_init_block (&singleblock
);
4377 gfc_add_expr_to_block (&singleblock
, res
);
4378 singleblock_in_progress
= true;
4381 /* Add the new statement to the block. */
4382 gfc_add_expr_to_block (pblock
, res
);
4384 prev_singleunit
= (ompws_flags
& OMPWS_CURR_SINGLEUNIT
) != 0;
4388 /* Finish remaining SINGLE block, if we were in the middle of one. */
4389 if (singleblock_in_progress
)
4391 /* Finish single block and add it to pblock. */
4392 tmp
= gfc_finish_block (&singleblock
);
4393 tmp
= build2_loc (input_location
, OMP_SINGLE
, void_type_node
, tmp
,
4395 ? build_omp_clause (input_location
, OMP_CLAUSE_NOWAIT
)
4397 gfc_add_expr_to_block (pblock
, tmp
);
4400 stmt
= gfc_finish_block (pblock
);
4401 if (TREE_CODE (stmt
) != BIND_EXPR
)
4403 if (!IS_EMPTY_STMT (stmt
))
4405 tree bindblock
= poplevel (1, 0);
4406 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, bindblock
);
4414 if (IS_EMPTY_STMT (stmt
) && !clauses
->nowait
)
4415 stmt
= gfc_trans_omp_barrier ();
4422 gfc_trans_oacc_declare (gfc_code
*code
)
4425 tree stmt
, oacc_clauses
;
4426 enum tree_code construct_code
;
4428 construct_code
= OACC_DATA
;
4430 gfc_start_block (&block
);
4432 oacc_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.oacc_declare
->clauses
,
4434 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
4435 stmt
= build2_loc (input_location
, construct_code
, void_type_node
, stmt
,
4437 gfc_add_expr_to_block (&block
, stmt
);
4439 return gfc_finish_block (&block
);
4443 gfc_trans_oacc_directive (gfc_code
*code
)
4447 case EXEC_OACC_PARALLEL_LOOP
:
4448 case EXEC_OACC_KERNELS_LOOP
:
4449 return gfc_trans_oacc_combined_directive (code
);
4450 case EXEC_OACC_PARALLEL
:
4451 case EXEC_OACC_KERNELS
:
4452 case EXEC_OACC_DATA
:
4453 case EXEC_OACC_HOST_DATA
:
4454 return gfc_trans_oacc_construct (code
);
4455 case EXEC_OACC_LOOP
:
4456 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
4458 case EXEC_OACC_UPDATE
:
4459 case EXEC_OACC_CACHE
:
4460 case EXEC_OACC_ENTER_DATA
:
4461 case EXEC_OACC_EXIT_DATA
:
4462 return gfc_trans_oacc_executable_directive (code
);
4463 case EXEC_OACC_WAIT
:
4464 return gfc_trans_oacc_wait_directive (code
);
4465 case EXEC_OACC_ATOMIC
:
4466 return gfc_trans_omp_atomic (code
);
4467 case EXEC_OACC_DECLARE
:
4468 return gfc_trans_oacc_declare (code
);
4475 gfc_trans_omp_directive (gfc_code
*code
)
4479 case EXEC_OMP_ATOMIC
:
4480 return gfc_trans_omp_atomic (code
);
4481 case EXEC_OMP_BARRIER
:
4482 return gfc_trans_omp_barrier ();
4483 case EXEC_OMP_CANCEL
:
4484 return gfc_trans_omp_cancel (code
);
4485 case EXEC_OMP_CANCELLATION_POINT
:
4486 return gfc_trans_omp_cancellation_point (code
);
4487 case EXEC_OMP_CRITICAL
:
4488 return gfc_trans_omp_critical (code
);
4489 case EXEC_OMP_DISTRIBUTE
:
4492 return gfc_trans_omp_do (code
, code
->op
, NULL
, code
->ext
.omp_clauses
,
4494 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4495 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4496 case EXEC_OMP_DISTRIBUTE_SIMD
:
4497 return gfc_trans_omp_distribute (code
, NULL
);
4498 case EXEC_OMP_DO_SIMD
:
4499 return gfc_trans_omp_do_simd (code
, NULL
, NULL
, NULL_TREE
);
4500 case EXEC_OMP_FLUSH
:
4501 return gfc_trans_omp_flush ();
4502 case EXEC_OMP_MASTER
:
4503 return gfc_trans_omp_master (code
);
4504 case EXEC_OMP_ORDERED
:
4505 return gfc_trans_omp_ordered (code
);
4506 case EXEC_OMP_PARALLEL
:
4507 return gfc_trans_omp_parallel (code
);
4508 case EXEC_OMP_PARALLEL_DO
:
4509 return gfc_trans_omp_parallel_do (code
, NULL
, NULL
);
4510 case EXEC_OMP_PARALLEL_DO_SIMD
:
4511 return gfc_trans_omp_parallel_do_simd (code
, NULL
, NULL
);
4512 case EXEC_OMP_PARALLEL_SECTIONS
:
4513 return gfc_trans_omp_parallel_sections (code
);
4514 case EXEC_OMP_PARALLEL_WORKSHARE
:
4515 return gfc_trans_omp_parallel_workshare (code
);
4516 case EXEC_OMP_SECTIONS
:
4517 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
4518 case EXEC_OMP_SINGLE
:
4519 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
4520 case EXEC_OMP_TARGET
:
4521 case EXEC_OMP_TARGET_TEAMS
:
4522 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4523 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4524 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4525 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4526 return gfc_trans_omp_target (code
);
4527 case EXEC_OMP_TARGET_DATA
:
4528 return gfc_trans_omp_target_data (code
);
4529 case EXEC_OMP_TARGET_UPDATE
:
4530 return gfc_trans_omp_target_update (code
);
4532 return gfc_trans_omp_task (code
);
4533 case EXEC_OMP_TASKGROUP
:
4534 return gfc_trans_omp_taskgroup (code
);
4535 case EXEC_OMP_TASKWAIT
:
4536 return gfc_trans_omp_taskwait ();
4537 case EXEC_OMP_TASKYIELD
:
4538 return gfc_trans_omp_taskyield ();
4539 case EXEC_OMP_TEAMS
:
4540 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4541 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4542 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4543 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4544 return gfc_trans_omp_teams (code
, NULL
);
4545 case EXEC_OMP_WORKSHARE
:
4546 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);
4553 gfc_trans_omp_declare_simd (gfc_namespace
*ns
)
4558 gfc_omp_declare_simd
*ods
;
4559 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
4561 tree c
= gfc_trans_omp_clauses (NULL
, ods
->clauses
, ods
->where
, true);
4562 tree fndecl
= ns
->proc_name
->backend_decl
;
4564 c
= tree_cons (NULL_TREE
, c
, NULL_TREE
);
4565 c
= build_tree_list (get_identifier ("omp declare simd"), c
);
4566 TREE_CHAIN (c
) = DECL_ATTRIBUTES (fndecl
);
4567 DECL_ATTRIBUTES (fndecl
) = c
;