1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2005, 2006, 2007, 2008 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"
26 #include "tree-gimple.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
39 /* True if OpenMP should privatize what this DECL points to rather
40 than the DECL itself. */
43 gfc_omp_privatize_by_reference (const_tree decl)
45 tree type = TREE_TYPE (decl);
47 if (TREE_CODE (type) == REFERENCE_TYPE
48 && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
51 if (TREE_CODE (type) == POINTER_TYPE)
53 /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
54 that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
55 set are supposed to be privatized by reference. */
56 if (GFC_POINTER_TYPE_P (type))
59 if (!DECL_ARTIFICIAL (decl))
62 /* Some arrays are expanded as DECL_ARTIFICIAL pointers
64 if (DECL_LANG_SPECIFIC (decl)
65 && GFC_DECL_SAVED_DESCRIPTOR (decl))
72 /* True if OpenMP sharing attribute of DECL is predetermined. */
74 enum omp_clause_default_kind
75 gfc_omp_predetermined_sharing (tree decl)
77 if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
78 return OMP_CLAUSE_DEFAULT_SHARED;
80 /* Cray pointees shouldn't be listed in any clauses and should be
81 gimplified to dereference of the corresponding Cray pointer.
82 Make them all private, so that they are emitted in the debug
84 if (GFC_DECL_CRAY_POINTEE (decl))
85 return OMP_CLAUSE_DEFAULT_PRIVATE;
87 /* COMMON and EQUIVALENCE decls are shared. They
88 are only referenced through DECL_VALUE_EXPR of the variables
89 contained in them. If those are privatized, they will not be
90 gimplified to the COMMON or EQUIVALENCE decls. */
91 if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
92 return OMP_CLAUSE_DEFAULT_SHARED;
94 if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
95 return OMP_CLAUSE_DEFAULT_SHARED;
97 return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
101 /* Return code to initialize DECL with its default constructor, or
102 NULL if there's nothing to do. */
105 gfc_omp_clause_default_ctor (tree clause ATTRIBUTE_UNUSED, tree decl)
107 tree type = TREE_TYPE (decl);
110 if (! GFC_DESCRIPTOR_TYPE_P (type))
113 /* Allocatable arrays in PRIVATE clauses need to be set to
114 "not currently allocated" allocation status. */
115 gfc_init_block (&block);
117 gfc_conv_descriptor_data_set_tuples (&block, decl, null_pointer_node);
119 return gfc_finish_block (&block);
123 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
124 disregarded in OpenMP construct, because it is going to be
125 remapped during OpenMP lowering. SHARED is true if DECL
126 is going to be shared, false if it is going to be privatized. */
129 gfc_omp_disregard_value_expr (tree decl, bool shared)
131 if (GFC_DECL_COMMON_OR_EQUIV (decl)
132 && DECL_HAS_VALUE_EXPR_P (decl))
134 tree value = DECL_VALUE_EXPR (decl);
136 if (TREE_CODE (value) == COMPONENT_REF
137 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
138 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
140 /* If variable in COMMON or EQUIVALENCE is privatized, return
141 true, as just that variable is supposed to be privatized,
142 not the whole COMMON or whole EQUIVALENCE.
143 For shared variables in COMMON or EQUIVALENCE, let them be
144 gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
145 from the same COMMON or EQUIVALENCE just one sharing of the
146 whole COMMON or EQUIVALENCE is enough. */
151 if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
157 /* Return true if DECL that is shared iff SHARED is true should
158 be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
162 gfc_omp_private_debug_clause (tree decl, bool shared)
164 if (GFC_DECL_CRAY_POINTEE (decl))
167 if (GFC_DECL_COMMON_OR_EQUIV (decl)
168 && DECL_HAS_VALUE_EXPR_P (decl))
170 tree value = DECL_VALUE_EXPR (decl);
172 if (TREE_CODE (value) == COMPONENT_REF
173 && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
174 && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
181 /* Register language specific type size variables as potentially OpenMP
182 firstprivate variables. */
185 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
187 if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
191 gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
192 for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
194 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
195 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
196 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
198 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
199 omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
205 gfc_trans_add_clause (tree node, tree tail)
207 OMP_CLAUSE_CHAIN (node) = tail;
212 gfc_trans_omp_variable (gfc_symbol *sym)
214 tree t = gfc_get_symbol_decl (sym);
218 bool alternate_entry;
221 return_value = sym->attr.function && sym->result == sym;
222 alternate_entry = sym->attr.function && sym->attr.entry
223 && sym->result == sym;
224 entry_master = sym->attr.result
225 && sym->ns->proc_name->attr.entry_master
226 && !gfc_return_by_reference (sym->ns->proc_name);
227 parent_decl = DECL_CONTEXT (current_function_decl);
229 if ((t == parent_decl && return_value)
230 || (sym->ns && sym->ns->proc_name
231 && sym->ns->proc_name->backend_decl == parent_decl
232 && (alternate_entry || entry_master)))
237 /* Special case for assigning the return value of a function.
238 Self recursive functions must have an explicit return value. */
239 if (return_value && (t == current_function_decl || parent_flag))
240 t = gfc_get_fake_result_decl (sym, parent_flag);
242 /* Similarly for alternate entry points. */
243 else if (alternate_entry
244 && (sym->ns->proc_name->backend_decl == current_function_decl
247 gfc_entry_list *el = NULL;
249 for (el = sym->ns->entries; el; el = el->next)
252 t = gfc_get_fake_result_decl (sym, parent_flag);
257 else if (entry_master
258 && (sym->ns->proc_name->backend_decl == current_function_decl
260 t = gfc_get_fake_result_decl (sym, parent_flag);
266 gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
269 for (; namelist != NULL; namelist = namelist->next)
270 if (namelist->sym->attr.referenced)
272 tree t = gfc_trans_omp_variable (namelist->sym);
273 if (t != error_mark_node)
275 tree node = build_omp_clause (code);
276 OMP_CLAUSE_DECL (node) = t;
277 list = gfc_trans_add_clause (node, list);
284 gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
286 gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
287 gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
288 gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
289 gfc_expr *e1, *e2, *e3, *e4;
291 tree decl, backend_decl, stmt;
292 locus old_loc = gfc_current_locus;
296 decl = OMP_CLAUSE_DECL (c);
297 gfc_current_locus = where;
299 /* Create a fake symbol for init value. */
300 memset (&init_val_sym, 0, sizeof (init_val_sym));
301 init_val_sym.ns = sym->ns;
302 init_val_sym.name = sym->name;
303 init_val_sym.ts = sym->ts;
304 init_val_sym.attr.referenced = 1;
305 init_val_sym.declared_at = where;
306 init_val_sym.attr.flavor = FL_VARIABLE;
307 backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
308 init_val_sym.backend_decl = backend_decl;
310 /* Create a fake symbol for the outer array reference. */
312 outer_sym.as = gfc_copy_array_spec (sym->as);
313 outer_sym.attr.dummy = 0;
314 outer_sym.attr.result = 0;
315 outer_sym.attr.flavor = FL_VARIABLE;
316 outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
318 /* Create fake symtrees for it. */
319 symtree1 = gfc_new_symtree (&root1, sym->name);
320 symtree1->n.sym = sym;
321 gcc_assert (symtree1 == root1);
323 symtree2 = gfc_new_symtree (&root2, sym->name);
324 symtree2->n.sym = &init_val_sym;
325 gcc_assert (symtree2 == root2);
327 symtree3 = gfc_new_symtree (&root3, sym->name);
328 symtree3->n.sym = &outer_sym;
329 gcc_assert (symtree3 == root3);
331 /* Create expressions. */
332 e1 = gfc_get_expr ();
333 e1->expr_type = EXPR_VARIABLE;
335 e1->symtree = symtree1;
337 e1->ref = ref = gfc_get_ref ();
338 ref->u.ar.where = where;
339 ref->u.ar.as = sym->as;
340 ref->u.ar.type = AR_FULL;
342 t = gfc_resolve_expr (e1);
343 gcc_assert (t == SUCCESS);
345 e2 = gfc_get_expr ();
346 e2->expr_type = EXPR_VARIABLE;
348 e2->symtree = symtree2;
350 t = gfc_resolve_expr (e2);
351 gcc_assert (t == SUCCESS);
353 e3 = gfc_copy_expr (e1);
354 e3->symtree = symtree3;
355 t = gfc_resolve_expr (e3);
356 gcc_assert (t == SUCCESS);
359 switch (OMP_CLAUSE_REDUCTION_CODE (c))
363 e4 = gfc_add (e3, e1);
366 e4 = gfc_multiply (e3, e1);
368 case TRUTH_ANDIF_EXPR:
369 e4 = gfc_and (e3, e1);
371 case TRUTH_ORIF_EXPR:
372 e4 = gfc_or (e3, e1);
375 e4 = gfc_eqv (e3, e1);
378 e4 = gfc_neqv (e3, e1);
400 memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
401 intrinsic_sym.ns = sym->ns;
402 intrinsic_sym.name = iname;
403 intrinsic_sym.ts = sym->ts;
404 intrinsic_sym.attr.referenced = 1;
405 intrinsic_sym.attr.intrinsic = 1;
406 intrinsic_sym.attr.function = 1;
407 intrinsic_sym.result = &intrinsic_sym;
408 intrinsic_sym.declared_at = where;
410 symtree4 = gfc_new_symtree (&root4, iname);
411 symtree4->n.sym = &intrinsic_sym;
412 gcc_assert (symtree4 == root4);
414 e4 = gfc_get_expr ();
415 e4->expr_type = EXPR_FUNCTION;
417 e4->symtree = symtree4;
418 e4->value.function.isym = gfc_find_function (iname);
419 e4->value.function.actual = gfc_get_actual_arglist ();
420 e4->value.function.actual->expr = e3;
421 e4->value.function.actual->next = gfc_get_actual_arglist ();
422 e4->value.function.actual->next->expr = e1;
424 /* e1 and e3 have been stored as arguments of e4, avoid sharing. */
425 e1 = gfc_copy_expr (e1);
426 e3 = gfc_copy_expr (e3);
427 t = gfc_resolve_expr (e4);
428 gcc_assert (t == SUCCESS);
430 /* Create the init statement list. */
432 stmt = gfc_trans_assignment (e1, e2, false);
433 if (TREE_CODE (stmt) != BIND_EXPR)
434 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
437 OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
439 /* Create the merge statement list. */
441 stmt = gfc_trans_assignment (e3, e4, false);
442 if (TREE_CODE (stmt) != BIND_EXPR)
443 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
446 OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
448 /* And stick the placeholder VAR_DECL into the clause as well. */
449 OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
451 gfc_current_locus = old_loc;
462 gfc_free_array_spec (outer_sym.as);
466 gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
467 enum tree_code reduction_code, locus where)
469 for (; namelist != NULL; namelist = namelist->next)
470 if (namelist->sym->attr.referenced)
472 tree t = gfc_trans_omp_variable (namelist->sym);
473 if (t != error_mark_node)
475 tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
476 OMP_CLAUSE_DECL (node) = t;
477 OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
478 if (namelist->sym->attr.dimension)
479 gfc_trans_omp_array_reduction (node, namelist->sym, where);
480 list = gfc_trans_add_clause (node, list);
487 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
490 tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
492 enum omp_clause_code clause_code;
498 for (list = 0; list < OMP_LIST_NUM; list++)
500 gfc_namelist *n = clauses->lists[list];
504 if (list >= OMP_LIST_REDUCTION_FIRST
505 && list <= OMP_LIST_REDUCTION_LAST)
507 enum tree_code reduction_code;
511 reduction_code = PLUS_EXPR;
514 reduction_code = MULT_EXPR;
517 reduction_code = MINUS_EXPR;
520 reduction_code = TRUTH_ANDIF_EXPR;
523 reduction_code = TRUTH_ORIF_EXPR;
526 reduction_code = EQ_EXPR;
529 reduction_code = NE_EXPR;
532 reduction_code = MAX_EXPR;
535 reduction_code = MIN_EXPR;
538 reduction_code = BIT_AND_EXPR;
541 reduction_code = BIT_IOR_EXPR;
544 reduction_code = BIT_XOR_EXPR;
549 old_clauses = omp_clauses;
551 = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
557 case OMP_LIST_PRIVATE:
558 clause_code = OMP_CLAUSE_PRIVATE;
560 case OMP_LIST_SHARED:
561 clause_code = OMP_CLAUSE_SHARED;
563 case OMP_LIST_FIRSTPRIVATE:
564 clause_code = OMP_CLAUSE_FIRSTPRIVATE;
566 case OMP_LIST_LASTPRIVATE:
567 clause_code = OMP_CLAUSE_LASTPRIVATE;
569 case OMP_LIST_COPYIN:
570 clause_code = OMP_CLAUSE_COPYIN;
572 case OMP_LIST_COPYPRIVATE:
573 clause_code = OMP_CLAUSE_COPYPRIVATE;
577 = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
584 if (clauses->if_expr)
588 gfc_init_se (&se, NULL);
589 gfc_conv_expr (&se, clauses->if_expr);
590 gfc_add_block_to_block (block, &se.pre);
591 if_var = gfc_evaluate_now (se.expr, block);
592 gfc_add_block_to_block (block, &se.post);
594 c = build_omp_clause (OMP_CLAUSE_IF);
595 OMP_CLAUSE_IF_EXPR (c) = if_var;
596 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
599 if (clauses->num_threads)
603 gfc_init_se (&se, NULL);
604 gfc_conv_expr (&se, clauses->num_threads);
605 gfc_add_block_to_block (block, &se.pre);
606 num_threads = gfc_evaluate_now (se.expr, block);
607 gfc_add_block_to_block (block, &se.post);
609 c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
610 OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
611 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
614 chunk_size = NULL_TREE;
615 if (clauses->chunk_size)
617 gfc_init_se (&se, NULL);
618 gfc_conv_expr (&se, clauses->chunk_size);
619 gfc_add_block_to_block (block, &se.pre);
620 chunk_size = gfc_evaluate_now (se.expr, block);
621 gfc_add_block_to_block (block, &se.post);
624 if (clauses->sched_kind != OMP_SCHED_NONE)
626 c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
627 OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
628 switch (clauses->sched_kind)
630 case OMP_SCHED_STATIC:
631 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
633 case OMP_SCHED_DYNAMIC:
634 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
636 case OMP_SCHED_GUIDED:
637 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
639 case OMP_SCHED_RUNTIME:
640 OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
645 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
648 if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
650 c = build_omp_clause (OMP_CLAUSE_DEFAULT);
651 switch (clauses->default_sharing)
653 case OMP_DEFAULT_NONE:
654 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
656 case OMP_DEFAULT_SHARED:
657 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
659 case OMP_DEFAULT_PRIVATE:
660 OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
665 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
670 c = build_omp_clause (OMP_CLAUSE_NOWAIT);
671 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
674 if (clauses->ordered)
676 c = build_omp_clause (OMP_CLAUSE_ORDERED);
677 omp_clauses = gfc_trans_add_clause (c, omp_clauses);
683 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
686 gfc_trans_omp_code (gfc_code *code, bool force_empty)
691 stmt = gfc_trans_code (code);
692 if (TREE_CODE (stmt) != BIND_EXPR)
694 if (!IS_EMPTY_STMT (stmt) || force_empty)
696 tree block = poplevel (1, 0, 0);
697 stmt = build3_v (BIND_EXPR, NULL, stmt, block);
708 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
709 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
712 gfc_trans_omp_atomic (gfc_code *code)
719 tree lhsaddr, type, rhs, x;
720 enum tree_code op = ERROR_MARK;
721 bool var_on_left = false;
723 code = code->block->next;
724 gcc_assert (code->op == EXEC_ASSIGN);
725 gcc_assert (code->next == NULL);
726 var = code->expr->symtree->n.sym;
728 gfc_init_se (&lse, NULL);
729 gfc_init_se (&rse, NULL);
730 gfc_start_block (&block);
732 gfc_conv_expr (&lse, code->expr);
733 gfc_add_block_to_block (&block, &lse.pre);
734 type = TREE_TYPE (lse.expr);
735 lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
738 if (expr2->expr_type == EXPR_FUNCTION
739 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
740 expr2 = expr2->value.function.actual->expr;
742 if (expr2->expr_type == EXPR_OP)
745 switch (expr2->value.op.operator)
750 case INTRINSIC_TIMES:
753 case INTRINSIC_MINUS:
756 case INTRINSIC_DIVIDE:
757 if (expr2->ts.type == BT_INTEGER)
763 op = TRUTH_ANDIF_EXPR;
766 op = TRUTH_ORIF_EXPR;
777 e = expr2->value.op.op1;
778 if (e->expr_type == EXPR_FUNCTION
779 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
780 e = e->value.function.actual->expr;
781 if (e->expr_type == EXPR_VARIABLE
782 && e->symtree != NULL
783 && e->symtree->n.sym == var)
785 expr2 = expr2->value.op.op2;
790 e = expr2->value.op.op2;
791 if (e->expr_type == EXPR_FUNCTION
792 && e->value.function.isym->id == GFC_ISYM_CONVERSION)
793 e = e->value.function.actual->expr;
794 gcc_assert (e->expr_type == EXPR_VARIABLE
795 && e->symtree != NULL
796 && e->symtree->n.sym == var);
797 expr2 = expr2->value.op.op1;
800 gfc_conv_expr (&rse, expr2);
801 gfc_add_block_to_block (&block, &rse.pre);
805 gcc_assert (expr2->expr_type == EXPR_FUNCTION);
806 switch (expr2->value.function.isym->id)
826 e = expr2->value.function.actual->expr;
827 gcc_assert (e->expr_type == EXPR_VARIABLE
828 && e->symtree != NULL
829 && e->symtree->n.sym == var);
831 gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
832 gfc_add_block_to_block (&block, &rse.pre);
833 if (expr2->value.function.actual->next->next != NULL)
835 tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
836 gfc_actual_arglist *arg;
838 gfc_add_modify_stmt (&block, accum, rse.expr);
839 for (arg = expr2->value.function.actual->next->next; arg;
842 gfc_init_block (&rse.pre);
843 gfc_conv_expr (&rse, arg->expr);
844 gfc_add_block_to_block (&block, &rse.pre);
845 x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
846 gfc_add_modify_stmt (&block, accum, x);
852 expr2 = expr2->value.function.actual->next->expr;
855 lhsaddr = save_expr (lhsaddr);
856 rhs = gfc_evaluate_now (rse.expr, &block);
857 x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));
860 x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
862 x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
864 if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
865 && TREE_CODE (type) != COMPLEX_TYPE)
866 x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
868 x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
869 gfc_add_expr_to_block (&block, x);
871 gfc_add_block_to_block (&block, &lse.pre);
872 gfc_add_block_to_block (&block, &rse.pre);
874 return gfc_finish_block (&block);
878 gfc_trans_omp_barrier (void)
880 tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
881 return build_call_expr (decl, 0);
885 gfc_trans_omp_critical (gfc_code *code)
887 tree name = NULL_TREE, stmt;
888 if (code->ext.omp_name != NULL)
889 name = get_identifier (code->ext.omp_name);
890 stmt = gfc_trans_code (code->block->next);
891 return build2_v (OMP_CRITICAL, stmt, name);
895 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
896 gfc_omp_clauses *do_clauses)
899 tree dovar, stmt, from, to, step, type, init, cond, incr;
900 tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
904 bool dovar_found = false;
905 gfc_omp_clauses *clauses = code->ext.omp_clauses;
907 code = code->block->next;
908 gcc_assert (code->op == EXEC_DO);
912 gfc_start_block (&block);
916 omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
920 for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next)
921 if (code->ext.iterator->var->symtree->n.sym == n->sym)
924 for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
925 if (code->ext.iterator->var->symtree->n.sym == n->sym)
931 /* Evaluate all the expressions in the iterator. */
932 gfc_init_se (&se, NULL);
933 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
934 gfc_add_block_to_block (pblock, &se.pre);
936 type = TREE_TYPE (dovar);
937 gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
939 gfc_init_se (&se, NULL);
940 gfc_conv_expr_val (&se, code->ext.iterator->start);
941 gfc_add_block_to_block (pblock, &se.pre);
942 from = gfc_evaluate_now (se.expr, pblock);
944 gfc_init_se (&se, NULL);
945 gfc_conv_expr_val (&se, code->ext.iterator->end);
946 gfc_add_block_to_block (pblock, &se.pre);
947 to = gfc_evaluate_now (se.expr, pblock);
949 gfc_init_se (&se, NULL);
950 gfc_conv_expr_val (&se, code->ext.iterator->step);
951 gfc_add_block_to_block (pblock, &se.pre);
952 step = gfc_evaluate_now (se.expr, pblock);
954 /* Special case simple loops. */
955 if (integer_onep (step))
957 else if (tree_int_cst_equal (step, integer_minus_one_node))
963 init = build2_v (GIMPLE_MODIFY_STMT, dovar, from);
964 cond = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node,
966 incr = fold_build2 (PLUS_EXPR, type, dovar, step);
967 incr = fold_build2 (GIMPLE_MODIFY_STMT, type, dovar, incr);
968 if (pblock != &block)
971 gfc_start_block (&block);
973 gfc_start_block (&body);
977 /* STEP is not 1 or -1. Use:
978 for (count = 0; count < (to + step - from) / step; count++)
980 dovar = from + count * step;
984 tmp = fold_build2 (MINUS_EXPR, type, step, from);
985 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
986 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
987 tmp = gfc_evaluate_now (tmp, pblock);
988 count = gfc_create_var (type, "count");
989 init = build2_v (GIMPLE_MODIFY_STMT, count, build_int_cst (type, 0));
990 cond = fold_build2 (LT_EXPR, boolean_type_node, count, tmp);
991 incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1));
992 incr = fold_build2 (GIMPLE_MODIFY_STMT, type, count, incr);
994 if (pblock != &block)
997 gfc_start_block (&block);
999 gfc_start_block (&body);
1001 /* Initialize DOVAR. */
1002 tmp = fold_build2 (MULT_EXPR, type, count, step);
1003 tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
1004 gfc_add_modify_stmt (&body, dovar, tmp);
1009 tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
1010 OMP_CLAUSE_DECL (tmp) = dovar;
1011 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1015 tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
1016 OMP_CLAUSE_DECL (tmp) = count;
1017 omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1020 /* Cycle statement is implemented with a goto. Exit statement must not be
1021 present for this loop. */
1022 cycle_label = gfc_build_label_decl (NULL_TREE);
1024 /* Put these labels where they can be found later. We put the
1025 labels in a TREE_LIST node (because TREE_CHAIN is already
1026 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
1027 label in TREE_VALUE (backend_decl). */
1029 code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
1031 /* Main loop body. */
1032 tmp = gfc_trans_omp_code (code->block->next, true);
1033 gfc_add_expr_to_block (&body, tmp);
1035 /* Label for cycle statements (if needed). */
1036 if (TREE_USED (cycle_label))
1038 tmp = build1_v (LABEL_EXPR, cycle_label);
1039 gfc_add_expr_to_block (&body, tmp);
1042 /* End of loop body. */
1043 stmt = make_node (OMP_FOR);
1045 TREE_TYPE (stmt) = void_type_node;
1046 OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1047 OMP_FOR_CLAUSES (stmt) = omp_clauses;
1048 OMP_FOR_INIT (stmt) = init;
1049 OMP_FOR_COND (stmt) = cond;
1050 OMP_FOR_INCR (stmt) = incr;
1051 gfc_add_expr_to_block (&block, stmt);
1053 return gfc_finish_block (&block);
1057 gfc_trans_omp_flush (void)
1059 tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1060 return build_call_expr (decl, 0);
1064 gfc_trans_omp_master (gfc_code *code)
1066 tree stmt = gfc_trans_code (code->block->next);
1067 if (IS_EMPTY_STMT (stmt))
1069 return build1_v (OMP_MASTER, stmt);
1073 gfc_trans_omp_ordered (gfc_code *code)
1075 return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1079 gfc_trans_omp_parallel (gfc_code *code)
1082 tree stmt, omp_clauses;
1084 gfc_start_block (&block);
1085 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1087 stmt = gfc_trans_omp_code (code->block->next, true);
1088 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1089 gfc_add_expr_to_block (&block, stmt);
1090 return gfc_finish_block (&block);
1094 gfc_trans_omp_parallel_do (gfc_code *code)
1096 stmtblock_t block, *pblock = NULL;
1097 gfc_omp_clauses parallel_clauses, do_clauses;
1098 tree stmt, omp_clauses = NULL_TREE;
1100 gfc_start_block (&block);
1102 memset (&do_clauses, 0, sizeof (do_clauses));
1103 if (code->ext.omp_clauses != NULL)
1105 memcpy (¶llel_clauses, code->ext.omp_clauses,
1106 sizeof (parallel_clauses));
1107 do_clauses.sched_kind = parallel_clauses.sched_kind;
1108 do_clauses.chunk_size = parallel_clauses.chunk_size;
1109 do_clauses.ordered = parallel_clauses.ordered;
1110 parallel_clauses.sched_kind = OMP_SCHED_NONE;
1111 parallel_clauses.chunk_size = NULL;
1112 parallel_clauses.ordered = false;
1113 omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
1116 do_clauses.nowait = true;
1117 if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1121 stmt = gfc_trans_omp_do (code, pblock, &do_clauses);
1122 if (TREE_CODE (stmt) != BIND_EXPR)
1123 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1126 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1127 OMP_PARALLEL_COMBINED (stmt) = 1;
1128 gfc_add_expr_to_block (&block, stmt);
1129 return gfc_finish_block (&block);
1133 gfc_trans_omp_parallel_sections (gfc_code *code)
1136 gfc_omp_clauses section_clauses;
1137 tree stmt, omp_clauses;
1139 memset (§ion_clauses, 0, sizeof (section_clauses));
1140 section_clauses.nowait = true;
1142 gfc_start_block (&block);
1143 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1146 stmt = gfc_trans_omp_sections (code, §ion_clauses);
1147 if (TREE_CODE (stmt) != BIND_EXPR)
1148 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1151 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1152 OMP_PARALLEL_COMBINED (stmt) = 1;
1153 gfc_add_expr_to_block (&block, stmt);
1154 return gfc_finish_block (&block);
1158 gfc_trans_omp_parallel_workshare (gfc_code *code)
1161 gfc_omp_clauses workshare_clauses;
1162 tree stmt, omp_clauses;
1164 memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1165 workshare_clauses.nowait = true;
1167 gfc_start_block (&block);
1168 omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1171 stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1172 if (TREE_CODE (stmt) != BIND_EXPR)
1173 stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1176 stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
1177 OMP_PARALLEL_COMBINED (stmt) = 1;
1178 gfc_add_expr_to_block (&block, stmt);
1179 return gfc_finish_block (&block);
1183 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1185 stmtblock_t block, body;
1186 tree omp_clauses, stmt;
1187 bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1189 gfc_start_block (&block);
1191 omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1193 gfc_init_block (&body);
1194 for (code = code->block; code; code = code->block)
1196 /* Last section is special because of lastprivate, so even if it
1197 is empty, chain it in. */
1198 stmt = gfc_trans_omp_code (code->next,
1199 has_lastprivate && code->block == NULL);
1200 if (! IS_EMPTY_STMT (stmt))
1202 stmt = build1_v (OMP_SECTION, stmt);
1203 gfc_add_expr_to_block (&body, stmt);
1206 stmt = gfc_finish_block (&body);
1208 stmt = build3_v (OMP_SECTIONS, stmt, omp_clauses, NULL_TREE);
1209 gfc_add_expr_to_block (&block, stmt);
1211 return gfc_finish_block (&block);
1215 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1217 tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1218 tree stmt = gfc_trans_omp_code (code->block->next, true);
1219 stmt = build2_v (OMP_SINGLE, stmt, omp_clauses);
1224 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1227 return gfc_trans_omp_single (code, clauses);
1231 gfc_trans_omp_directive (gfc_code *code)
1235 case EXEC_OMP_ATOMIC:
1236 return gfc_trans_omp_atomic (code);
1237 case EXEC_OMP_BARRIER:
1238 return gfc_trans_omp_barrier ();
1239 case EXEC_OMP_CRITICAL:
1240 return gfc_trans_omp_critical (code);
1242 return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses);
1243 case EXEC_OMP_FLUSH:
1244 return gfc_trans_omp_flush ();
1245 case EXEC_OMP_MASTER:
1246 return gfc_trans_omp_master (code);
1247 case EXEC_OMP_ORDERED:
1248 return gfc_trans_omp_ordered (code);
1249 case EXEC_OMP_PARALLEL:
1250 return gfc_trans_omp_parallel (code);
1251 case EXEC_OMP_PARALLEL_DO:
1252 return gfc_trans_omp_parallel_do (code);
1253 case EXEC_OMP_PARALLEL_SECTIONS:
1254 return gfc_trans_omp_parallel_sections (code);
1255 case EXEC_OMP_PARALLEL_WORKSHARE:
1256 return gfc_trans_omp_parallel_workshare (code);
1257 case EXEC_OMP_SECTIONS:
1258 return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1259 case EXEC_OMP_SINGLE:
1260 return gfc_trans_omp_single (code, code->ext.omp_clauses);
1261 case EXEC_OMP_WORKSHARE:
1262 return gfc_trans_omp_workshare (code, code->ext.omp_clauses);