static tree gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) { stmtblock_t block, body; tree omp_clauses, stmt; bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; gfc_start_block (&block); omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); gfc_init_block (&body); for (code = code->block; code; code = code->block) { /* Last section is special because of lastprivate, so even if it is empty, chain it in. */ stmt = gfc_trans_omp_code (code->next, has_lastprivate && code->block == NULL); if (! IS_EMPTY_STMT (stmt)) { stmt = build1_v (OMP_SECTION, stmt); gfc_add_expr_to_block (&body, stmt); } } stmt = gfc_finish_block (&body); stmt = build2_v (OMP_SECTIONS, stmt, omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); }
static tree gfc_trans_omp_master (gfc_code *code) { tree stmt = gfc_trans_code (code->block->next); if (IS_EMPTY_STMT (stmt)) return stmt; return build1_v (OMP_MASTER, stmt); }
/* User-deallocate; we emit the code directly from the front-end, and the logic is the same as the previous library function: void deallocate (void *pointer, GFC_INTEGER_4 * stat) { if (!pointer) { if (stat) *stat = 1; else runtime_error ("Attempt to DEALLOCATE unallocated memory."); } else { free (pointer); if (stat) *stat = 0; } } In this front-end version, status doesn't have to be GFC_INTEGER_4. Moreover, if CAN_FAIL is true, then we will not emit a runtime error, even when no status variable is passed to us (this is used for unconditional deallocation generated by the front-end at end of each procedure). If a runtime-message is possible, `expr' must point to the original expression being deallocated for its locus and variable name. For coarrays, "pointer" must be the array descriptor and not its "data" component. */ tree gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, tree label_finish, bool can_fail, gfc_expr* expr, bool coarray) { stmtblock_t null, non_null; tree cond, tmp, error; tree status_type = NULL_TREE; tree caf_decl = NULL_TREE; if (coarray) { gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))); caf_decl = pointer; pointer = gfc_conv_descriptor_data_get (caf_decl); STRIP_NOPS (pointer); } cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise we emit a runtime error. */ gfc_start_block (&null); if (!can_fail) { tree varname; gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); varname = gfc_build_cstring_const (expr->symtree->name); varname = gfc_build_addr_expr (pchar_type_node, varname); error = gfc_trans_runtime_error (true, &expr->where, "Attempt to DEALLOCATE unallocated '%s'", varname); } else error = build_empty_stmt (input_location); if (status != NULL_TREE && !integer_zerop (status)) { tree cond2; status_type = TREE_TYPE (TREE_TYPE (status)); cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), build_int_cst (status_type, 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } gfc_add_expr_to_block (&null, error); /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) { tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); gfc_add_expr_to_block (&non_null, tmp); if (status != NULL_TREE && !integer_zerop (status)) { /* We set STATUS to zero if it is present. */ tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), build_int_cst (status_type, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&non_null, tmp); } } else { tree caf_type, token, cond2; tree pstat = null_pointer_node; if (errmsg == NULL_TREE) { gcc_assert (errlen == NULL_TREE); errmsg = null_pointer_node; errlen = build_zero_cst (integer_type_node); } else { gcc_assert (errlen != NULL_TREE); if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); } caf_type = TREE_TYPE (caf_decl); if (status != NULL_TREE && !integer_zerop (status)) { gcc_assert (status_type == integer_type_node); pstat = status; } if (GFC_DESCRIPTOR_TYPE_P (caf_type) && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) token = gfc_conv_descriptor_token (caf_decl); else if (DECL_LANG_SPECIFIC (caf_decl) && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) token = GFC_DECL_TOKEN (caf_decl); else { gcc_assert (GFC_ARRAY_TYPE_P (caf_type) && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); } token = gfc_build_addr_expr (NULL_TREE, token); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 4, token, pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); if (status != NULL_TREE) { tree stat = build_fold_indirect_ref_loc (input_location, status); TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_zero_cst (TREE_TYPE (stat))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&non_null, tmp); } } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, gfc_finish_block (&null), gfc_finish_block (&non_null)); }
/* Generate code for an ALLOCATE statement when the argument is an allocatable variable. If the variable is currently allocated, it is an error to allocate it again. This function follows the following pseudo-code: void * allocate_allocatable (void *mem, size_t size, integer_type stat) { if (mem == NULL) return allocate (size, stat); else { if (stat) stat = LIBERROR_ALLOCATION; else runtime_error ("Attempting to allocate already allocated variable"); } } expr must be set to the original expression being allocated for its locus and variable name in case a runtime error has to be printed. */ void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, tree status, tree errmsg, tree errlen, tree label_finish, gfc_expr* expr) { stmtblock_t alloc_block; tree tmp, null_mem, alloc, error; tree type = TREE_TYPE (mem); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node, mem, build_int_cst (type, 0))); /* If mem is NULL, we call gfc_allocate_using_malloc or gfc_allocate_using_lib. */ gfc_start_block (&alloc_block); if (gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_expr_attr (expr).codimension) { tree cond; gfc_allocate_using_lib (&alloc_block, mem, size, token, status, errmsg, errlen); if (status != NULL_TREE) { TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_zero_cst (TREE_TYPE (status))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); } } else gfc_allocate_using_malloc (&alloc_block, mem, size, status); alloc = gfc_finish_block (&alloc_block); /* If mem is not NULL, we issue a runtime error or set the status variable. */ if (expr) { tree varname; gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); varname = gfc_build_cstring_const (expr->symtree->name); varname = gfc_build_addr_expr (pchar_type_node, varname); error = gfc_trans_runtime_error (true, &expr->where, "Attempting to allocate already" " allocated variable '%s'", varname); } else error = gfc_trans_runtime_error (true, NULL, "Attempting to allocate already allocated" " variable"); if (status != NULL_TREE) { tree status_type = TREE_TYPE (status); error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, build_int_cst (status_type, LIBERROR_ALLOCATION)); } tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, error, alloc); gfc_add_expr_to_block (block, tmp); }
static tree gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses) { gfc_se se; tree dovar, stmt, from, to, step, type, init, cond, incr; tree count = NULL_TREE, cycle_label, tmp, omp_clauses; stmtblock_t block; stmtblock_t body; int simple = 0; bool dovar_found = false; gfc_omp_clauses *clauses = code->ext.omp_clauses; code = code->block->next; gcc_assert (code->op == EXEC_DO); if (pblock == NULL) { gfc_start_block (&block); pblock = █ } omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); if (clauses) { gfc_namelist *n; for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next) if (code->ext.iterator->var->symtree->n.sym == n->sym) break; if (n == NULL) for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) if (code->ext.iterator->var->symtree->n.sym == n->sym) break; if (n != NULL) dovar_found = true; } /* Evaluate all the expressions in the iterator. */ gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->ext.iterator->var); gfc_add_block_to_block (pblock, &se.pre); dovar = se.expr; type = TREE_TYPE (dovar); gcc_assert (TREE_CODE (type) == INTEGER_TYPE); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->start); gfc_add_block_to_block (pblock, &se.pre); from = gfc_evaluate_now (se.expr, pblock); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->end); gfc_add_block_to_block (pblock, &se.pre); to = gfc_evaluate_now (se.expr, pblock); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->step); gfc_add_block_to_block (pblock, &se.pre); step = gfc_evaluate_now (se.expr, pblock); /* Special case simple loops. */ if (integer_onep (step)) simple = 1; else if (tree_int_cst_equal (step, integer_minus_one_node)) simple = -1; /* Loop body. */ if (simple) { init = build2_v (MODIFY_EXPR, dovar, from); cond = build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node, dovar, to); incr = fold_build2 (PLUS_EXPR, type, dovar, step); incr = fold_build2 (MODIFY_EXPR, type, dovar, incr); if (pblock != &block) { pushlevel (0); gfc_start_block (&block); } gfc_start_block (&body); } else { /* STEP is not 1 or -1. Use: for (count = 0; count < (to + step - from) / step; count++) { dovar = from + count * step; body; cycle_label:; } */ tmp = fold_build2 (MINUS_EXPR, type, step, from); tmp = fold_build2 (PLUS_EXPR, type, to, tmp); tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); tmp = gfc_evaluate_now (tmp, pblock); count = gfc_create_var (type, "count"); init = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0)); cond = build2 (LT_EXPR, boolean_type_node, count, tmp); incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1)); incr = fold_build2 (MODIFY_EXPR, type, count, incr); if (pblock != &block) { pushlevel (0); gfc_start_block (&block); } gfc_start_block (&body); /* Initialize DOVAR. */ tmp = fold_build2 (MULT_EXPR, type, count, step); tmp = build2 (PLUS_EXPR, type, from, tmp); gfc_add_modify_expr (&body, dovar, tmp); } if (!dovar_found) { tmp = build_omp_clause (OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = dovar; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } if (!simple) { tmp = build_omp_clause (OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = count; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } /* Cycle statement is implemented with a goto. Exit statement must not be present for this loop. */ cycle_label = gfc_build_label_decl (NULL_TREE); /* Put these labels where they can be found later. We put the labels in a TREE_LIST node (because TREE_CHAIN is already used). cycle_label goes in TREE_PURPOSE (backend_decl), exit label in TREE_VALUE (backend_decl). */ code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); /* Main loop body. */ tmp = gfc_trans_omp_code (code->block->next, true); gfc_add_expr_to_block (&body, tmp); /* Label for cycle statements (if needed). */ if (TREE_USED (cycle_label)) { tmp = build1_v (LABEL_EXPR, cycle_label); gfc_add_expr_to_block (&body, tmp); } /* End of loop body. */ stmt = make_node (OMP_FOR); TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = gfc_finish_block (&body); OMP_FOR_CLAUSES (stmt) = omp_clauses; OMP_FOR_INIT (stmt) = init; OMP_FOR_COND (stmt) = cond; OMP_FOR_INCR (stmt) = incr; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); }
static tree gfc_trans_omp_ordered (gfc_code *code) { return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next)); }
static tree gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_clauses) { gfc_se se; tree dovar, stmt, from, to, step, type, init, cond, incr; tree count = NULL_TREE, cycle_label, tmp, omp_clauses; stmtblock_t block; stmtblock_t body; gfc_omp_clauses *clauses = code->ext.omp_clauses; int i, collapse = clauses->collapse; tree dovar_init = NULL_TREE; if (collapse <= 0) collapse = 1; code = code->block->next; gcc_assert (code->op == EXEC_DO); init = make_tree_vec (collapse); cond = make_tree_vec (collapse); incr = make_tree_vec (collapse); if (pblock == NULL) { gfc_start_block (&block); pblock = █ } omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); for (i = 0; i < collapse; i++) { int simple = 0; int dovar_found = 0; tree dovar_decl; if (clauses) { gfc_namelist *n; for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next) if (code->ext.iterator->var->symtree->n.sym == n->sym) break; if (n != NULL) dovar_found = 1; else if (n == NULL) for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) if (code->ext.iterator->var->symtree->n.sym == n->sym) break; if (n != NULL) dovar_found++; } /* Evaluate all the expressions in the iterator. */ gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->ext.iterator->var); gfc_add_block_to_block (pblock, &se.pre); dovar = se.expr; type = TREE_TYPE (dovar); gcc_assert (TREE_CODE (type) == INTEGER_TYPE); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->start); gfc_add_block_to_block (pblock, &se.pre); from = gfc_evaluate_now (se.expr, pblock); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->end); gfc_add_block_to_block (pblock, &se.pre); to = gfc_evaluate_now (se.expr, pblock); gfc_init_se (&se, NULL); gfc_conv_expr_val (&se, code->ext.iterator->step); gfc_add_block_to_block (pblock, &se.pre); step = gfc_evaluate_now (se.expr, pblock); dovar_decl = dovar; /* Special case simple loops. */ if (TREE_CODE (dovar) == VAR_DECL) { if (integer_onep (step)) simple = 1; else if (tree_int_cst_equal (step, integer_minus_one_node)) simple = -1; } else dovar_decl = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym); /* Loop body. */ if (simple) { TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node, dovar, to); TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step); TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar, TREE_VEC_ELT (incr, i)); } else { /* STEP is not 1 or -1. Use: for (count = 0; count < (to + step - from) / step; count++) { dovar = from + count * step; body; cycle_label:; } */ tmp = fold_build2 (MINUS_EXPR, type, step, from); tmp = fold_build2 (PLUS_EXPR, type, to, tmp); tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); tmp = gfc_evaluate_now (tmp, pblock); count = gfc_create_var (type, "count"); TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0)); TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node, count, tmp); TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1)); TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, count, TREE_VEC_ELT (incr, i)); /* Initialize DOVAR. */ tmp = fold_build2 (MULT_EXPR, type, count, step); tmp = fold_build2 (PLUS_EXPR, type, from, tmp); dovar_init = tree_cons (dovar, tmp, dovar_init); } if (!dovar_found) { tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = dovar_decl; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } else if (dovar_found == 2) { tree c = NULL; tmp = NULL; if (!simple) { /* If dovar is lastprivate, but different counter is used, dovar += step needs to be added to OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar will have the value on entry of the last loop, rather than value after iterator increment. */ tmp = gfc_evaluate_now (step, pblock); tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp); tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp); for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE && OMP_CLAUSE_DECL (c) == dovar_decl) { OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; break; } } if (c == NULL && par_clauses != NULL) { for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE && OMP_CLAUSE_DECL (c) == dovar_decl) { tree l = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); OMP_CLAUSE_DECL (l) = dovar_decl; OMP_CLAUSE_CHAIN (l) = omp_clauses; OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; omp_clauses = l; OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); break; } } gcc_assert (simple || c != NULL); } if (!simple) { tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = count; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } if (i + 1 < collapse) code = code->block->next; } if (pblock != &block) { pushlevel (0); gfc_start_block (&block); } gfc_start_block (&body); dovar_init = nreverse (dovar_init); while (dovar_init) { gfc_add_modify (&body, TREE_PURPOSE (dovar_init), TREE_VALUE (dovar_init)); dovar_init = TREE_CHAIN (dovar_init); } /* Cycle statement is implemented with a goto. Exit statement must not be present for this loop. */ cycle_label = gfc_build_label_decl (NULL_TREE); /* Put these labels where they can be found later. We put the labels in a TREE_LIST node (because TREE_CHAIN is already used). cycle_label goes in TREE_PURPOSE (backend_decl), exit label in TREE_VALUE (backend_decl). */ code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); /* Main loop body. */ tmp = gfc_trans_omp_code (code->block->next, true); gfc_add_expr_to_block (&body, tmp); /* Label for cycle statements (if needed). */ if (TREE_USED (cycle_label)) { tmp = build1_v (LABEL_EXPR, cycle_label); gfc_add_expr_to_block (&body, tmp); } /* End of loop body. */ stmt = make_node (OMP_FOR); TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = gfc_finish_block (&body); OMP_FOR_CLAUSES (stmt) = omp_clauses; OMP_FOR_INIT (stmt) = init; OMP_FOR_COND (stmt) = cond; OMP_FOR_INCR (stmt) = incr; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); }