1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005, 2006 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 2, 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 COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "coretypes.h"
27 #include "tree-gimple.h"
33 #include "trans-stmt.h"
34 #include "trans-types.h"
35 #include "trans-array.h"
36 #include "trans-const.h"
40 /* True if OpenMP should privatize what this DECL points to rather
41 than the DECL itself. */
44 gfc_omp_privatize_by_reference (tree decl
)
46 tree type
= TREE_TYPE (decl
);
48 if (TREE_CODE (type
) == REFERENCE_TYPE
)
51 if (TREE_CODE (type
) == POINTER_TYPE
)
53 /* POINTER/ALLOCATABLE have aggregate types, all user variables
54 that have POINTER_TYPE type are supposed to be privatized
56 if (!DECL_ARTIFICIAL (decl
))
59 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
61 if (DECL_LANG_SPECIFIC (decl
)
62 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
69 /* True if OpenMP sharing attribute of DECL is predetermined. */
71 enum omp_clause_default_kind
72 gfc_omp_predetermined_sharing (tree decl
)
74 if (DECL_ARTIFICIAL (decl
) && ! GFC_DECL_RESULT (decl
))
75 return OMP_CLAUSE_DEFAULT_SHARED
;
77 /* Cray pointees shouldn't be listed in any clauses and should be
78 gimplified to dereference of the corresponding Cray pointer.
79 Make them all private, so that they are emitted in the debug
81 if (GFC_DECL_CRAY_POINTEE (decl
))
82 return OMP_CLAUSE_DEFAULT_PRIVATE
;
84 /* COMMON and EQUIVALENCE decls are shared. They
85 are only referenced through DECL_VALUE_EXPR of the variables
86 contained in them. If those are privatized, they will not be
87 gimplified to the COMMON or EQUIVALENCE decls. */
88 if (GFC_DECL_COMMON_OR_EQUIV (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
89 return OMP_CLAUSE_DEFAULT_SHARED
;
91 if (GFC_DECL_RESULT (decl
) && ! DECL_HAS_VALUE_EXPR_P (decl
))
92 return OMP_CLAUSE_DEFAULT_SHARED
;
94 return OMP_CLAUSE_DEFAULT_UNSPECIFIED
;
97 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
98 disregarded in OpenMP construct, because it is going to be
99 remapped during OpenMP lowering. SHARED is true if DECL
100 is going to be shared, false if it is going to be privatized. */
103 gfc_omp_disregard_value_expr (tree decl
, bool shared
)
105 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
106 && DECL_HAS_VALUE_EXPR_P (decl
))
108 tree value
= DECL_VALUE_EXPR (decl
);
110 if (TREE_CODE (value
) == COMPONENT_REF
111 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
112 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
114 /* If variable in COMMON or EQUIVALENCE is privatized, return
115 true, as just that variable is supposed to be privatized,
116 not the whole COMMON or whole EQUIVALENCE.
117 For shared variables in COMMON or EQUIVALENCE, let them be
118 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
119 from the same COMMON or EQUIVALENCE just one sharing of the
120 whole COMMON or EQUIVALENCE is enough. */
125 if (GFC_DECL_RESULT (decl
) && DECL_HAS_VALUE_EXPR_P (decl
))
131 /* Return true if DECL that is shared iff SHARED is true should
132 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
136 gfc_omp_private_debug_clause (tree decl
, bool shared
)
138 if (GFC_DECL_CRAY_POINTEE (decl
))
141 if (GFC_DECL_COMMON_OR_EQUIV (decl
)
142 && DECL_HAS_VALUE_EXPR_P (decl
))
144 tree value
= DECL_VALUE_EXPR (decl
);
146 if (TREE_CODE (value
) == COMPONENT_REF
147 && TREE_CODE (TREE_OPERAND (value
, 0)) == VAR_DECL
148 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value
, 0)))
155 /* Register language specific type size variables as potentially OpenMP
156 firstprivate variables. */
159 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx
*ctx
, tree type
)
161 if (GFC_ARRAY_TYPE_P (type
) || GFC_DESCRIPTOR_TYPE_P (type
))
165 gcc_assert (TYPE_LANG_SPECIFIC (type
) != NULL
);
166 for (r
= 0; r
< GFC_TYPE_ARRAY_RANK (type
); r
++)
168 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_LBOUND (type
, r
));
169 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_UBOUND (type
, r
));
170 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_STRIDE (type
, r
));
172 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_SIZE (type
));
173 omp_firstprivatize_variable (ctx
, GFC_TYPE_ARRAY_OFFSET (type
));
179 gfc_trans_add_clause (tree node
, tree tail
)
181 OMP_CLAUSE_CHAIN (node
) = tail
;
186 gfc_trans_omp_variable (gfc_symbol
*sym
)
188 tree t
= gfc_get_symbol_decl (sym
);
192 bool alternate_entry
;
195 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
196 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
197 && sym
->result
== sym
;
198 entry_master
= sym
->attr
.result
199 && sym
->ns
->proc_name
->attr
.entry_master
200 && !gfc_return_by_reference (sym
->ns
->proc_name
);
201 parent_decl
= DECL_CONTEXT (current_function_decl
);
203 if ((t
== parent_decl
&& return_value
)
204 || (sym
->ns
&& sym
->ns
->proc_name
205 && sym
->ns
->proc_name
->backend_decl
== parent_decl
206 && (alternate_entry
|| entry_master
)))
211 /* Special case for assigning the return value of a function.
212 Self recursive functions must have an explicit return value. */
213 if (return_value
&& (t
== current_function_decl
|| parent_flag
))
214 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
216 /* Similarly for alternate entry points. */
217 else if (alternate_entry
218 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
221 gfc_entry_list
*el
= NULL
;
223 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
226 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
231 else if (entry_master
232 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
234 t
= gfc_get_fake_result_decl (sym
, parent_flag
);
240 gfc_trans_omp_variable_list (enum omp_clause_code code
, gfc_namelist
*namelist
,
243 for (; namelist
!= NULL
; namelist
= namelist
->next
)
244 if (namelist
->sym
->attr
.referenced
)
246 tree t
= gfc_trans_omp_variable (namelist
->sym
);
247 if (t
!= error_mark_node
)
249 tree node
= build_omp_clause (code
);
250 OMP_CLAUSE_DECL (node
) = t
;
251 list
= gfc_trans_add_clause (node
, list
);
258 gfc_trans_omp_array_reduction (tree c
, gfc_symbol
*sym
, locus where
)
260 gfc_symtree
*root1
= NULL
, *root2
= NULL
, *root3
= NULL
, *root4
= NULL
;
261 gfc_symtree
*symtree1
, *symtree2
, *symtree3
, *symtree4
= NULL
;
262 gfc_symbol init_val_sym
, outer_sym
, intrinsic_sym
;
263 gfc_expr
*e1
, *e2
, *e3
, *e4
;
265 tree decl
, backend_decl
;
266 locus old_loc
= gfc_current_locus
;
270 decl
= OMP_CLAUSE_DECL (c
);
271 gfc_current_locus
= where
;
273 /* Create a fake symbol for init value. */
274 memset (&init_val_sym
, 0, sizeof (init_val_sym
));
275 init_val_sym
.ns
= sym
->ns
;
276 init_val_sym
.name
= sym
->name
;
277 init_val_sym
.ts
= sym
->ts
;
278 init_val_sym
.attr
.referenced
= 1;
279 init_val_sym
.declared_at
= where
;
280 backend_decl
= omp_reduction_init (c
, gfc_sym_type (&init_val_sym
));
281 init_val_sym
.backend_decl
= backend_decl
;
283 /* Create a fake symbol for the outer array reference. */
285 outer_sym
.as
= gfc_copy_array_spec (sym
->as
);
286 outer_sym
.attr
.dummy
= 0;
287 outer_sym
.attr
.result
= 0;
288 outer_sym
.backend_decl
= create_tmp_var_raw (TREE_TYPE (decl
), NULL
);
290 /* Create fake symtrees for it. */
291 symtree1
= gfc_new_symtree (&root1
, sym
->name
);
292 symtree1
->n
.sym
= sym
;
293 gcc_assert (symtree1
== root1
);
295 symtree2
= gfc_new_symtree (&root2
, sym
->name
);
296 symtree2
->n
.sym
= &init_val_sym
;
297 gcc_assert (symtree2
== root2
);
299 symtree3
= gfc_new_symtree (&root3
, sym
->name
);
300 symtree3
->n
.sym
= &outer_sym
;
301 gcc_assert (symtree3
== root3
);
303 /* Create expressions. */
304 e1
= gfc_get_expr ();
305 e1
->expr_type
= EXPR_VARIABLE
;
307 e1
->symtree
= symtree1
;
309 e1
->ref
= ref
= gfc_get_ref ();
310 ref
->u
.ar
.where
= where
;
311 ref
->u
.ar
.as
= sym
->as
;
312 ref
->u
.ar
.type
= AR_FULL
;
314 t
= gfc_resolve_expr (e1
);
315 gcc_assert (t
== SUCCESS
);
317 e2
= gfc_get_expr ();
318 e2
->expr_type
= EXPR_VARIABLE
;
320 e2
->symtree
= symtree2
;
322 t
= gfc_resolve_expr (e2
);
323 gcc_assert (t
== SUCCESS
);
325 e3
= gfc_copy_expr (e1
);
326 e3
->symtree
= symtree3
;
327 t
= gfc_resolve_expr (e3
);
328 gcc_assert (t
== SUCCESS
);
331 switch (OMP_CLAUSE_REDUCTION_CODE (c
))
335 e4
= gfc_add (e3
, e1
);
338 e4
= gfc_multiply (e3
, e1
);
340 case TRUTH_ANDIF_EXPR
:
341 e4
= gfc_and (e3
, e1
);
343 case TRUTH_ORIF_EXPR
:
344 e4
= gfc_or (e3
, e1
);
347 e4
= gfc_eqv (e3
, e1
);
350 e4
= gfc_neqv (e3
, e1
);
372 memset (&intrinsic_sym
, 0, sizeof (intrinsic_sym
));
373 intrinsic_sym
.ns
= sym
->ns
;
374 intrinsic_sym
.name
= iname
;
375 intrinsic_sym
.ts
= sym
->ts
;
376 intrinsic_sym
.attr
.referenced
= 1;
377 intrinsic_sym
.attr
.intrinsic
= 1;
378 intrinsic_sym
.attr
.function
= 1;
379 intrinsic_sym
.result
= &intrinsic_sym
;
380 intrinsic_sym
.declared_at
= where
;
382 symtree4
= gfc_new_symtree (&root4
, iname
);
383 symtree4
->n
.sym
= &intrinsic_sym
;
384 gcc_assert (symtree4
== root4
);
386 e4
= gfc_get_expr ();
387 e4
->expr_type
= EXPR_FUNCTION
;
389 e4
->symtree
= symtree4
;
390 e4
->value
.function
.isym
= gfc_find_function (iname
);
391 e4
->value
.function
.actual
= gfc_get_actual_arglist ();
392 e4
->value
.function
.actual
->expr
= e3
;
393 e4
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
394 e4
->value
.function
.actual
->next
->expr
= e1
;
396 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
397 e1
= gfc_copy_expr (e1
);
398 e3
= gfc_copy_expr (e3
);
399 t
= gfc_resolve_expr (e4
);
400 gcc_assert (t
== SUCCESS
);
402 /* Create the init statement list. */
403 OMP_CLAUSE_REDUCTION_INIT (c
) = gfc_trans_assignment (e1
, e2
);
405 /* Create the merge statement list. */
406 OMP_CLAUSE_REDUCTION_MERGE (c
) = gfc_trans_assignment (e3
, e4
);
408 /* And stick the placeholder VAR_DECL into the clause as well. */
409 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c
) = outer_sym
.backend_decl
;
411 gfc_current_locus
= old_loc
;
422 gfc_free_array_spec (outer_sym
.as
);
426 gfc_trans_omp_reduction_list (gfc_namelist
*namelist
, tree list
,
427 enum tree_code reduction_code
, locus where
)
429 for (; namelist
!= NULL
; namelist
= namelist
->next
)
430 if (namelist
->sym
->attr
.referenced
)
432 tree t
= gfc_trans_omp_variable (namelist
->sym
);
433 if (t
!= error_mark_node
)
435 tree node
= build_omp_clause (OMP_CLAUSE_REDUCTION
);
436 OMP_CLAUSE_DECL (node
) = t
;
437 OMP_CLAUSE_REDUCTION_CODE (node
) = reduction_code
;
438 if (namelist
->sym
->attr
.dimension
)
439 gfc_trans_omp_array_reduction (node
, namelist
->sym
, where
);
440 list
= gfc_trans_add_clause (node
, list
);
447 gfc_trans_omp_clauses (stmtblock_t
*block
, gfc_omp_clauses
*clauses
,
450 tree omp_clauses
= NULL_TREE
, chunk_size
, c
, old_clauses
;
452 enum omp_clause_code clause_code
;
458 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
460 gfc_namelist
*n
= clauses
->lists
[list
];
464 if (list
>= OMP_LIST_REDUCTION_FIRST
465 && list
<= OMP_LIST_REDUCTION_LAST
)
467 enum tree_code reduction_code
;
471 reduction_code
= PLUS_EXPR
;
474 reduction_code
= MULT_EXPR
;
477 reduction_code
= MINUS_EXPR
;
480 reduction_code
= TRUTH_ANDIF_EXPR
;
483 reduction_code
= TRUTH_ORIF_EXPR
;
486 reduction_code
= EQ_EXPR
;
489 reduction_code
= NE_EXPR
;
492 reduction_code
= MAX_EXPR
;
495 reduction_code
= MIN_EXPR
;
498 reduction_code
= BIT_AND_EXPR
;
501 reduction_code
= BIT_IOR_EXPR
;
504 reduction_code
= BIT_XOR_EXPR
;
509 old_clauses
= omp_clauses
;
511 = gfc_trans_omp_reduction_list (n
, omp_clauses
, reduction_code
,
517 case OMP_LIST_PRIVATE
:
518 clause_code
= OMP_CLAUSE_PRIVATE
;
520 case OMP_LIST_SHARED
:
521 clause_code
= OMP_CLAUSE_SHARED
;
523 case OMP_LIST_FIRSTPRIVATE
:
524 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
526 case OMP_LIST_LASTPRIVATE
:
527 clause_code
= OMP_CLAUSE_LASTPRIVATE
;
529 case OMP_LIST_COPYIN
:
530 clause_code
= OMP_CLAUSE_COPYIN
;
532 case OMP_LIST_COPYPRIVATE
:
533 clause_code
= OMP_CLAUSE_COPYPRIVATE
;
537 = gfc_trans_omp_variable_list (clause_code
, n
, omp_clauses
);
544 if (clauses
->if_expr
)
548 gfc_init_se (&se
, NULL
);
549 gfc_conv_expr (&se
, clauses
->if_expr
);
550 gfc_add_block_to_block (block
, &se
.pre
);
551 if_var
= gfc_evaluate_now (se
.expr
, block
);
552 gfc_add_block_to_block (block
, &se
.post
);
554 c
= build_omp_clause (OMP_CLAUSE_IF
);
555 OMP_CLAUSE_IF_EXPR (c
) = if_var
;
556 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
559 if (clauses
->num_threads
)
563 gfc_init_se (&se
, NULL
);
564 gfc_conv_expr (&se
, clauses
->num_threads
);
565 gfc_add_block_to_block (block
, &se
.pre
);
566 num_threads
= gfc_evaluate_now (se
.expr
, block
);
567 gfc_add_block_to_block (block
, &se
.post
);
569 c
= build_omp_clause (OMP_CLAUSE_NUM_THREADS
);
570 OMP_CLAUSE_NUM_THREADS_EXPR (c
) = num_threads
;
571 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
574 chunk_size
= NULL_TREE
;
575 if (clauses
->chunk_size
)
577 gfc_init_se (&se
, NULL
);
578 gfc_conv_expr (&se
, clauses
->chunk_size
);
579 gfc_add_block_to_block (block
, &se
.pre
);
580 chunk_size
= gfc_evaluate_now (se
.expr
, block
);
581 gfc_add_block_to_block (block
, &se
.post
);
584 if (clauses
->sched_kind
!= OMP_SCHED_NONE
)
586 c
= build_omp_clause (OMP_CLAUSE_SCHEDULE
);
587 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c
) = chunk_size
;
588 switch (clauses
->sched_kind
)
590 case OMP_SCHED_STATIC
:
591 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_STATIC
;
593 case OMP_SCHED_DYNAMIC
:
594 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_DYNAMIC
;
596 case OMP_SCHED_GUIDED
:
597 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_GUIDED
;
599 case OMP_SCHED_RUNTIME
:
600 OMP_CLAUSE_SCHEDULE_KIND (c
) = OMP_CLAUSE_SCHEDULE_RUNTIME
;
605 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
608 if (clauses
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
610 c
= build_omp_clause (OMP_CLAUSE_DEFAULT
);
611 switch (clauses
->default_sharing
)
613 case OMP_DEFAULT_NONE
:
614 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_NONE
;
616 case OMP_DEFAULT_SHARED
:
617 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_SHARED
;
619 case OMP_DEFAULT_PRIVATE
:
620 OMP_CLAUSE_DEFAULT_KIND (c
) = OMP_CLAUSE_DEFAULT_PRIVATE
;
625 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
630 c
= build_omp_clause (OMP_CLAUSE_NOWAIT
);
631 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
634 if (clauses
->ordered
)
636 c
= build_omp_clause (OMP_CLAUSE_ORDERED
);
637 omp_clauses
= gfc_trans_add_clause (c
, omp_clauses
);
643 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
646 gfc_trans_omp_code (gfc_code
*code
, bool force_empty
)
651 stmt
= gfc_trans_code (code
);
652 if (TREE_CODE (stmt
) != BIND_EXPR
)
654 if (!IS_EMPTY_STMT (stmt
) || force_empty
)
656 tree block
= poplevel (1, 0, 0);
657 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, block
);
668 static tree
gfc_trans_omp_sections (gfc_code
*, gfc_omp_clauses
*);
669 static tree
gfc_trans_omp_workshare (gfc_code
*, gfc_omp_clauses
*);
672 gfc_trans_omp_atomic (gfc_code
*code
)
679 tree lhsaddr
, type
, rhs
, x
;
680 enum tree_code op
= ERROR_MARK
;
681 bool var_on_left
= false;
683 code
= code
->block
->next
;
684 gcc_assert (code
->op
== EXEC_ASSIGN
);
685 gcc_assert (code
->next
== NULL
);
686 var
= code
->expr
->symtree
->n
.sym
;
688 gfc_init_se (&lse
, NULL
);
689 gfc_init_se (&rse
, NULL
);
690 gfc_start_block (&block
);
692 gfc_conv_expr (&lse
, code
->expr
);
693 gfc_add_block_to_block (&block
, &lse
.pre
);
694 type
= TREE_TYPE (lse
.expr
);
695 lhsaddr
= gfc_build_addr_expr (NULL
, lse
.expr
);
698 if (expr2
->expr_type
== EXPR_FUNCTION
699 && expr2
->value
.function
.isym
->generic_id
== GFC_ISYM_CONVERSION
)
700 expr2
= expr2
->value
.function
.actual
->expr
;
702 if (expr2
->expr_type
== EXPR_OP
)
705 switch (expr2
->value
.op
.operator)
710 case INTRINSIC_TIMES
:
713 case INTRINSIC_MINUS
:
716 case INTRINSIC_DIVIDE
:
717 if (expr2
->ts
.type
== BT_INTEGER
)
723 op
= TRUTH_ANDIF_EXPR
;
726 op
= TRUTH_ORIF_EXPR
;
737 e
= expr2
->value
.op
.op1
;
738 if (e
->expr_type
== EXPR_FUNCTION
739 && e
->value
.function
.isym
->generic_id
== GFC_ISYM_CONVERSION
)
740 e
= e
->value
.function
.actual
->expr
;
741 if (e
->expr_type
== EXPR_VARIABLE
742 && e
->symtree
!= NULL
743 && e
->symtree
->n
.sym
== var
)
745 expr2
= expr2
->value
.op
.op2
;
750 e
= expr2
->value
.op
.op2
;
751 if (e
->expr_type
== EXPR_FUNCTION
752 && e
->value
.function
.isym
->generic_id
== GFC_ISYM_CONVERSION
)
753 e
= e
->value
.function
.actual
->expr
;
754 gcc_assert (e
->expr_type
== EXPR_VARIABLE
755 && e
->symtree
!= NULL
756 && e
->symtree
->n
.sym
== var
);
757 expr2
= expr2
->value
.op
.op1
;
760 gfc_conv_expr (&rse
, expr2
);
761 gfc_add_block_to_block (&block
, &rse
.pre
);
765 gcc_assert (expr2
->expr_type
== EXPR_FUNCTION
);
766 switch (expr2
->value
.function
.isym
->generic_id
)
786 e
= expr2
->value
.function
.actual
->expr
;
787 gcc_assert (e
->expr_type
== EXPR_VARIABLE
788 && e
->symtree
!= NULL
789 && e
->symtree
->n
.sym
== var
);
791 gfc_conv_expr (&rse
, expr2
->value
.function
.actual
->next
->expr
);
792 gfc_add_block_to_block (&block
, &rse
.pre
);
793 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
795 tree accum
= gfc_create_var (TREE_TYPE (rse
.expr
), NULL
);
796 gfc_actual_arglist
*arg
;
798 gfc_add_modify_expr (&block
, accum
, rse
.expr
);
799 for (arg
= expr2
->value
.function
.actual
->next
->next
; arg
;
802 gfc_init_block (&rse
.pre
);
803 gfc_conv_expr (&rse
, arg
->expr
);
804 gfc_add_block_to_block (&block
, &rse
.pre
);
805 x
= fold_build2 (op
, TREE_TYPE (accum
), accum
, rse
.expr
);
806 gfc_add_modify_expr (&block
, accum
, x
);
812 expr2
= expr2
->value
.function
.actual
->next
->expr
;
815 lhsaddr
= save_expr (lhsaddr
);
816 rhs
= gfc_evaluate_now (rse
.expr
, &block
);
817 x
= convert (TREE_TYPE (rhs
), build_fold_indirect_ref (lhsaddr
));
820 x
= fold_build2 (op
, TREE_TYPE (rhs
), x
, rhs
);
822 x
= fold_build2 (op
, TREE_TYPE (rhs
), rhs
, x
);
824 if (TREE_CODE (TREE_TYPE (rhs
)) == COMPLEX_TYPE
825 && TREE_CODE (type
) != COMPLEX_TYPE
)
826 x
= build1 (REALPART_EXPR
, TREE_TYPE (TREE_TYPE (rhs
)), x
);
828 x
= build2_v (OMP_ATOMIC
, lhsaddr
, convert (type
, x
));
829 gfc_add_expr_to_block (&block
, x
);
831 gfc_add_block_to_block (&block
, &lse
.pre
);
832 gfc_add_block_to_block (&block
, &rse
.pre
);
834 return gfc_finish_block (&block
);
838 gfc_trans_omp_barrier (void)
840 tree decl
= built_in_decls
[BUILT_IN_GOMP_BARRIER
];
841 return build_function_call_expr (decl
, NULL
);
845 gfc_trans_omp_critical (gfc_code
*code
)
847 tree name
= NULL_TREE
, stmt
;
848 if (code
->ext
.omp_name
!= NULL
)
849 name
= get_identifier (code
->ext
.omp_name
);
850 stmt
= gfc_trans_code (code
->block
->next
);
851 return build2_v (OMP_CRITICAL
, stmt
, name
);
855 gfc_trans_omp_do (gfc_code
*code
, stmtblock_t
*pblock
,
856 gfc_omp_clauses
*clauses
)
859 tree dovar
, stmt
, from
, to
, step
, type
, init
, cond
, incr
;
860 tree count
= NULL_TREE
, cycle_label
, tmp
, omp_clauses
;
864 bool dovar_found
= false;
866 code
= code
->block
->next
;
867 gcc_assert (code
->op
== EXEC_DO
);
871 gfc_start_block (&block
);
875 omp_clauses
= gfc_trans_omp_clauses (pblock
, clauses
, code
->loc
);
879 for (n
= clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
!= NULL
; n
= n
->next
)
880 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
883 for (n
= clauses
->lists
[OMP_LIST_PRIVATE
]; n
!= NULL
; n
= n
->next
)
884 if (code
->ext
.iterator
->var
->symtree
->n
.sym
== n
->sym
)
890 /* Evaluate all the expressions in the iterator. */
891 gfc_init_se (&se
, NULL
);
892 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
893 gfc_add_block_to_block (pblock
, &se
.pre
);
895 type
= TREE_TYPE (dovar
);
896 gcc_assert (TREE_CODE (type
) == INTEGER_TYPE
);
898 gfc_init_se (&se
, NULL
);
899 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
900 gfc_add_block_to_block (pblock
, &se
.pre
);
901 from
= gfc_evaluate_now (se
.expr
, pblock
);
903 gfc_init_se (&se
, NULL
);
904 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
905 gfc_add_block_to_block (pblock
, &se
.pre
);
906 to
= gfc_evaluate_now (se
.expr
, pblock
);
908 gfc_init_se (&se
, NULL
);
909 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
910 gfc_add_block_to_block (pblock
, &se
.pre
);
911 step
= gfc_evaluate_now (se
.expr
, pblock
);
913 /* Special case simple loops. */
914 if (integer_onep (step
))
916 else if (tree_int_cst_equal (step
, integer_minus_one_node
))
922 init
= build2_v (MODIFY_EXPR
, dovar
, from
);
923 cond
= build2 (simple
> 0 ? LE_EXPR
: GE_EXPR
, boolean_type_node
,
925 incr
= fold_build2 (PLUS_EXPR
, type
, dovar
, step
);
926 incr
= fold_build2 (MODIFY_EXPR
, type
, dovar
, incr
);
927 if (pblock
!= &block
)
930 gfc_start_block (&block
);
932 gfc_start_block (&body
);
936 /* STEP is not 1 or -1. Use:
937 for (count = 0; count < (to + step - from) / step; count++)
939 dovar = from + count * step;
943 tmp
= fold_build2 (MINUS_EXPR
, type
, step
, from
);
944 tmp
= fold_build2 (PLUS_EXPR
, type
, to
, tmp
);
945 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
);
946 tmp
= gfc_evaluate_now (tmp
, pblock
);
947 count
= gfc_create_var (type
, "count");
948 init
= build2_v (MODIFY_EXPR
, count
, build_int_cst (type
, 0));
949 cond
= build2 (LT_EXPR
, boolean_type_node
, count
, tmp
);
950 incr
= fold_build2 (PLUS_EXPR
, type
, count
, build_int_cst (type
, 1));
951 incr
= fold_build2 (MODIFY_EXPR
, type
, count
, incr
);
953 if (pblock
!= &block
)
956 gfc_start_block (&block
);
958 gfc_start_block (&body
);
960 /* Initialize DOVAR. */
961 tmp
= fold_build2 (MULT_EXPR
, type
, count
, step
);
962 tmp
= build2 (PLUS_EXPR
, type
, from
, tmp
);
963 gfc_add_modify_expr (&body
, dovar
, tmp
);
968 tmp
= build_omp_clause (OMP_CLAUSE_PRIVATE
);
969 OMP_CLAUSE_DECL (tmp
) = dovar
;
970 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
974 tmp
= build_omp_clause (OMP_CLAUSE_PRIVATE
);
975 OMP_CLAUSE_DECL (tmp
) = count
;
976 omp_clauses
= gfc_trans_add_clause (tmp
, omp_clauses
);
979 /* Cycle statement is implemented with a goto. Exit statement must not be
980 present for this loop. */
981 cycle_label
= gfc_build_label_decl (NULL_TREE
);
983 /* Put these labels where they can be found later. We put the
984 labels in a TREE_LIST node (because TREE_CHAIN is already
985 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
986 label in TREE_VALUE (backend_decl). */
988 code
->block
->backend_decl
= tree_cons (cycle_label
, NULL
, NULL
);
990 /* Main loop body. */
991 tmp
= gfc_trans_omp_code (code
->block
->next
, true);
992 gfc_add_expr_to_block (&body
, tmp
);
994 /* Label for cycle statements (if needed). */
995 if (TREE_USED (cycle_label
))
997 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
998 gfc_add_expr_to_block (&body
, tmp
);
1001 /* End of loop body. */
1002 stmt
= make_node (OMP_FOR
);
1004 TREE_TYPE (stmt
) = void_type_node
;
1005 OMP_FOR_BODY (stmt
) = gfc_finish_block (&body
);
1006 OMP_FOR_CLAUSES (stmt
) = omp_clauses
;
1007 OMP_FOR_INIT (stmt
) = init
;
1008 OMP_FOR_COND (stmt
) = cond
;
1009 OMP_FOR_INCR (stmt
) = incr
;
1010 gfc_add_expr_to_block (&block
, stmt
);
1012 return gfc_finish_block (&block
);
1016 gfc_trans_omp_flush (void)
1018 tree decl
= built_in_decls
[BUILT_IN_SYNCHRONIZE
];
1019 return build_function_call_expr (decl
, NULL
);
1023 gfc_trans_omp_master (gfc_code
*code
)
1025 tree stmt
= gfc_trans_code (code
->block
->next
);
1026 if (IS_EMPTY_STMT (stmt
))
1028 return build1_v (OMP_MASTER
, stmt
);
1032 gfc_trans_omp_ordered (gfc_code
*code
)
1034 return build1_v (OMP_ORDERED
, gfc_trans_code (code
->block
->next
));
1038 gfc_trans_omp_parallel (gfc_code
*code
)
1041 tree stmt
, omp_clauses
;
1043 gfc_start_block (&block
);
1044 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1046 stmt
= gfc_trans_omp_code (code
->block
->next
, true);
1047 stmt
= build4_v (OMP_PARALLEL
, stmt
, omp_clauses
, NULL
, NULL
);
1048 gfc_add_expr_to_block (&block
, stmt
);
1049 return gfc_finish_block (&block
);
1053 gfc_trans_omp_parallel_do (gfc_code
*code
)
1055 stmtblock_t block
, *pblock
= NULL
;
1056 gfc_omp_clauses parallel_clauses
, do_clauses
;
1057 tree stmt
, omp_clauses
= NULL_TREE
;
1059 gfc_start_block (&block
);
1061 memset (&do_clauses
, 0, sizeof (do_clauses
));
1062 if (code
->ext
.omp_clauses
!= NULL
)
1064 memcpy (¶llel_clauses
, code
->ext
.omp_clauses
,
1065 sizeof (parallel_clauses
));
1066 do_clauses
.sched_kind
= parallel_clauses
.sched_kind
;
1067 do_clauses
.chunk_size
= parallel_clauses
.chunk_size
;
1068 do_clauses
.ordered
= parallel_clauses
.ordered
;
1069 parallel_clauses
.sched_kind
= OMP_SCHED_NONE
;
1070 parallel_clauses
.chunk_size
= NULL
;
1071 parallel_clauses
.ordered
= false;
1072 omp_clauses
= gfc_trans_omp_clauses (&block
, ¶llel_clauses
,
1075 do_clauses
.nowait
= true;
1076 if (!do_clauses
.ordered
&& do_clauses
.sched_kind
!= OMP_SCHED_STATIC
)
1080 stmt
= gfc_trans_omp_do (code
, pblock
, &do_clauses
);
1081 if (TREE_CODE (stmt
) != BIND_EXPR
)
1082 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1085 stmt
= build4_v (OMP_PARALLEL
, stmt
, omp_clauses
, NULL
, NULL
);
1086 gfc_add_expr_to_block (&block
, stmt
);
1087 return gfc_finish_block (&block
);
1091 gfc_trans_omp_parallel_sections (gfc_code
*code
)
1094 gfc_omp_clauses section_clauses
;
1095 tree stmt
, omp_clauses
;
1097 memset (§ion_clauses
, 0, sizeof (section_clauses
));
1098 section_clauses
.nowait
= true;
1100 gfc_start_block (&block
);
1101 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1104 stmt
= gfc_trans_omp_sections (code
, §ion_clauses
);
1105 if (TREE_CODE (stmt
) != BIND_EXPR
)
1106 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1109 stmt
= build4_v (OMP_PARALLEL
, stmt
, omp_clauses
, NULL
, NULL
);
1110 gfc_add_expr_to_block (&block
, stmt
);
1111 return gfc_finish_block (&block
);
1115 gfc_trans_omp_parallel_workshare (gfc_code
*code
)
1118 gfc_omp_clauses workshare_clauses
;
1119 tree stmt
, omp_clauses
;
1121 memset (&workshare_clauses
, 0, sizeof (workshare_clauses
));
1122 workshare_clauses
.nowait
= true;
1124 gfc_start_block (&block
);
1125 omp_clauses
= gfc_trans_omp_clauses (&block
, code
->ext
.omp_clauses
,
1128 stmt
= gfc_trans_omp_workshare (code
, &workshare_clauses
);
1129 if (TREE_CODE (stmt
) != BIND_EXPR
)
1130 stmt
= build3_v (BIND_EXPR
, NULL
, stmt
, poplevel (1, 0, 0));
1133 stmt
= build4_v (OMP_PARALLEL
, stmt
, omp_clauses
, NULL
, NULL
);
1134 gfc_add_expr_to_block (&block
, stmt
);
1135 return gfc_finish_block (&block
);
1139 gfc_trans_omp_sections (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1141 stmtblock_t block
, body
;
1142 tree omp_clauses
, stmt
;
1143 bool has_lastprivate
= clauses
->lists
[OMP_LIST_LASTPRIVATE
] != NULL
;
1145 gfc_start_block (&block
);
1147 omp_clauses
= gfc_trans_omp_clauses (&block
, clauses
, code
->loc
);
1149 gfc_init_block (&body
);
1150 for (code
= code
->block
; code
; code
= code
->block
)
1152 /* Last section is special because of lastprivate, so even if it
1153 is empty, chain it in. */
1154 stmt
= gfc_trans_omp_code (code
->next
,
1155 has_lastprivate
&& code
->block
== NULL
);
1156 if (! IS_EMPTY_STMT (stmt
))
1158 stmt
= build1_v (OMP_SECTION
, stmt
);
1159 gfc_add_expr_to_block (&body
, stmt
);
1162 stmt
= gfc_finish_block (&body
);
1164 stmt
= build3_v (OMP_SECTIONS
, stmt
, omp_clauses
, NULL
);
1165 gfc_add_expr_to_block (&block
, stmt
);
1167 return gfc_finish_block (&block
);
1171 gfc_trans_omp_single (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1173 tree omp_clauses
= gfc_trans_omp_clauses (NULL
, clauses
, code
->loc
);
1174 tree stmt
= gfc_trans_omp_code (code
->block
->next
, true);
1175 stmt
= build2_v (OMP_SINGLE
, stmt
, omp_clauses
);
1180 gfc_trans_omp_workshare (gfc_code
*code
, gfc_omp_clauses
*clauses
)
1183 return gfc_trans_omp_single (code
, clauses
);
1187 gfc_trans_omp_directive (gfc_code
*code
)
1191 case EXEC_OMP_ATOMIC
:
1192 return gfc_trans_omp_atomic (code
);
1193 case EXEC_OMP_BARRIER
:
1194 return gfc_trans_omp_barrier ();
1195 case EXEC_OMP_CRITICAL
:
1196 return gfc_trans_omp_critical (code
);
1198 return gfc_trans_omp_do (code
, NULL
, code
->ext
.omp_clauses
);
1199 case EXEC_OMP_FLUSH
:
1200 return gfc_trans_omp_flush ();
1201 case EXEC_OMP_MASTER
:
1202 return gfc_trans_omp_master (code
);
1203 case EXEC_OMP_ORDERED
:
1204 return gfc_trans_omp_ordered (code
);
1205 case EXEC_OMP_PARALLEL
:
1206 return gfc_trans_omp_parallel (code
);
1207 case EXEC_OMP_PARALLEL_DO
:
1208 return gfc_trans_omp_parallel_do (code
);
1209 case EXEC_OMP_PARALLEL_SECTIONS
:
1210 return gfc_trans_omp_parallel_sections (code
);
1211 case EXEC_OMP_PARALLEL_WORKSHARE
:
1212 return gfc_trans_omp_parallel_workshare (code
);
1213 case EXEC_OMP_SECTIONS
:
1214 return gfc_trans_omp_sections (code
, code
->ext
.omp_clauses
);
1215 case EXEC_OMP_SINGLE
:
1216 return gfc_trans_omp_single (code
, code
->ext
.omp_clauses
);
1217 case EXEC_OMP_WORKSHARE
:
1218 return gfc_trans_omp_workshare (code
, code
->ext
.omp_clauses
);