tree gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) { tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b; stmtblock_t block, cond_block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) return NULL; gcc_assert (outer != NULL); gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE); /* Allocatable arrays in PRIVATE clauses need to be set to "not currently allocated" allocation status if outer array is "not currently allocated", otherwise should be allocated. */ gfc_start_block (&block); gfc_init_block (&cond_block); gfc_add_modify (&cond_block, decl, outer); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (decl, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (decl, rank)); size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_stride_get (decl, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); ptr = gfc_allocate_array_with_status (&cond_block, build_int_cst (pvoid_type_node, 0), size, NULL, NULL); gfc_conv_descriptor_data_set (&cond_block, decl, ptr); then_b = gfc_finish_block (&cond_block); gfc_init_block (&cond_block); gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node); else_b = gfc_finish_block (&cond_block); cond = fold_build2 (NE_EXPR, boolean_type_node, fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (outer)), null_pointer_node); gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node, cond, then_b, else_b)); return gfc_finish_block (&block); }
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the following pseudo-code: void * internal_realloc (void *mem, size_t size) { if (size < 0) runtime_error ("Attempt to allocate a negative amount of memory."); res = realloc (mem, size); if (!res && size != 0) _gfortran_os_error ("Out of memory"); if (size == 0) return NULL; return res; } */ tree gfc_call_realloc (stmtblock_t * block, tree mem, tree size) { tree msg, res, negative, nonzero, zero, null_result, tmp; tree type = TREE_TYPE (mem); size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* Create a variable to hold the result. */ res = gfc_create_var (type, NULL); /* size < 0 ? */ negative = fold_build2 (LT_EXPR, boolean_type_node, size, build_int_cst (size_type_node, 0)); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Attempt to allocate a negative amount of memory.")); tmp = fold_build3 (COND_EXPR, void_type_node, negative, build_call_expr_loc (input_location, gfor_fndecl_runtime_error, 1, msg), build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); /* Call realloc and check the result. */ tmp = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_REALLOC], 2, fold_convert (pvoid_type_node, mem), size); gfc_add_modify (block, res, fold_convert (type, tmp)); null_result = fold_build2 (EQ_EXPR, boolean_type_node, res, build_int_cst (pvoid_type_node, 0)); nonzero = fold_build2 (NE_EXPR, boolean_type_node, size, build_int_cst (size_type_node, 0)); null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result, nonzero); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Out of memory")); tmp = fold_build3 (COND_EXPR, void_type_node, null_result, build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg), build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); /* if (size == 0) then the result is NULL. */ tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0)); zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero); tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); return res; }
/* Call malloc to allocate size bytes of memory, with special conditions: + if size == 0, return a malloced area of size 1, + if malloc returns NULL, issue a runtime error. */ tree gfc_call_malloc (stmtblock_t * block, tree type, tree size) { tree tmp, msg, malloc_result, null_result, res, malloc_tree; stmtblock_t block2; size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* Create a variable to hold the result. */ res = gfc_create_var (prvoid_type_node, NULL); /* Call malloc. */ gfc_start_block (&block2); size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)); malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC); gfc_add_modify (&block2, res, fold_convert (prvoid_type_node, build_call_expr_loc (input_location, malloc_tree, 1, size))); /* Optionally check whether malloc was successful. */ if (gfc_option.rtcheck & GFC_RTCHECK_MEM) { null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, res, build_int_cst (pvoid_type_node, 0)); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Memory allocation failed")); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_result, build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg), build_empty_stmt (input_location)); gfc_add_expr_to_block (&block2, tmp); } malloc_result = gfc_finish_block (&block2); gfc_add_expr_to_block (block, malloc_result); if (type != NULL) res = fold_convert (type, res); return res; }
/* Allocate memory, using an optional status argument. This function follows the following pseudo-code: void * allocate (size_t size, integer_type stat) { void *newmem; if (stat requested) stat = 0; newmem = malloc (MAX (size, 1)); if (newmem == NULL) { if (stat) *stat = LIBERROR_ALLOCATION; else runtime_error ("Allocation would exceed memory limit"); } return newmem; } */ void gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tree size, tree status) { tree tmp, on_error, error_cond; tree status_type = status ? TREE_TYPE (status) : NULL_TREE; /* Evaluate size only once, and make sure it has the right type. */ size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* If successful and stat= is given, set status to 0. */ if (status != NULL_TREE) gfc_add_expr_to_block (block, fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, build_int_cst (status_type, 0))); /* The allocation itself. */ gfc_add_modify (block, pointer, fold_convert (TREE_TYPE (pointer), build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MALLOC), 1, fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1))))); /* What to do in case of error. */ if (status != NULL_TREE) on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, build_int_cst (status_type, LIBERROR_ALLOCATION)); else on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Allocation would exceed memory limit"))); error_cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (error_cond), on_error, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); }
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the following pseudo-code: void * internal_realloc (void *mem, size_t size) { res = realloc (mem, size); if (!res && size != 0) _gfortran_os_error ("Allocation would exceed memory limit"); if (size == 0) return NULL; return res; } */ tree gfc_call_realloc (stmtblock_t * block, tree mem, tree size) { tree msg, res, nonzero, zero, null_result, tmp; tree type = TREE_TYPE (mem); size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* Create a variable to hold the result. */ res = gfc_create_var (type, NULL); /* Call realloc and check the result. */ tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, mem), size); gfc_add_modify (block, res, fold_convert (type, tmp)); null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, res, build_int_cst (pvoid_type_node, 0)); nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size, build_int_cst (size_type_node, 0)); null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, null_result, nonzero); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Allocation would exceed memory limit")); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_result, build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg), build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); /* if (size == 0) then the result is NULL. */ tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res, build_int_cst (type, 0)); zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node, nonzero); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); return res; }
tree gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { tree type = TREE_TYPE (dest), ptr, size, esize, rank, call; stmtblock_t block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) return build2_v (MODIFY_EXPR, dest, src); gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE); /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated and copied from SRC. */ gfc_start_block (&block); gfc_add_modify (&block, dest, src); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (dest, rank)); size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_stride_get (dest, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), size, NULL, NULL); gfc_conv_descriptor_data_set (&block, dest, ptr); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, ptr, fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (src)), size); gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); return gfc_finish_block (&block); }
/* Free a given variable, if it's not NULL. */ tree gfc_call_free (tree var) { stmtblock_t block; tree tmp, cond, call; if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node)) var = fold_convert (pvoid_type_node, var); gfc_start_block (&block); var = gfc_evaluate_now (var, &block); cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var, build_int_cst (pvoid_type_node, 0)); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_FREE], 1, var); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); }
/* Allocate memory, using an optional status argument. This function follows the following pseudo-code: void * allocate (size_t size, void** token, int *stat, char* errmsg, int errlen) { void *newmem; newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); return newmem; } */ static void gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, tree token, tree status, tree errmsg, tree errlen) { tree tmp, pstat; gcc_assert (token != NULL_TREE); /* Evaluate size only once, and make sure it has the right type. */ size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* The allocation itself. */ if (status == NULL_TREE) pstat = null_pointer_node; else pstat = gfc_build_addr_expr (NULL_TREE, status); if (errmsg == NULL_TREE) { gcc_assert(errlen == NULL_TREE); errmsg = null_pointer_node; errlen = build_int_cst (integer_type_node, 0); } tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)), build_int_cst (integer_type_node, GFC_CAF_COARRAY_ALLOC), token, pstat, errmsg, errlen); tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (pointer), pointer, fold_convert ( TREE_TYPE (pointer), tmp)); gfc_add_expr_to_block (block, tmp); }
tree gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) { tree type = TREE_TYPE (dest), rank, size, esize, call; stmtblock_t block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) return build2_v (MODIFY_EXPR, dest, src); /* Handle copying allocatable arrays. */ gfc_start_block (&block); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (dest, rank)); size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_stride_get (dest, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (dest)), fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (src)), size); gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); return gfc_finish_block (&block); }
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_atomic (gfc_code *code) { gfc_se lse; gfc_se rse; gfc_expr *expr2, *e; gfc_symbol *var; stmtblock_t block; tree lhsaddr, type, rhs, x; enum tree_code op = ERROR_MARK; bool var_on_left = false; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); gcc_assert (code->next == NULL); var = code->expr->symtree->n.sym; gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); gfc_start_block (&block); gfc_conv_expr (&lse, code->expr); gfc_add_block_to_block (&block, &lse.pre); type = TREE_TYPE (lse.expr); lhsaddr = gfc_build_addr_expr (NULL, lse.expr); expr2 = code->expr2; if (expr2->expr_type == EXPR_FUNCTION && expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; if (expr2->expr_type == EXPR_OP) { gfc_expr *e; switch (expr2->value.op.operator) { case INTRINSIC_PLUS: op = PLUS_EXPR; break; case INTRINSIC_TIMES: op = MULT_EXPR; break; case INTRINSIC_MINUS: op = MINUS_EXPR; break; case INTRINSIC_DIVIDE: if (expr2->ts.type == BT_INTEGER) op = TRUNC_DIV_EXPR; else op = RDIV_EXPR; break; case INTRINSIC_AND: op = TRUTH_ANDIF_EXPR; break; case INTRINSIC_OR: op = TRUTH_ORIF_EXPR; break; case INTRINSIC_EQV: op = EQ_EXPR; break; case INTRINSIC_NEQV: op = NE_EXPR; break; default: gcc_unreachable (); } e = expr2->value.op.op1; if (e->expr_type == EXPR_FUNCTION && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) { expr2 = expr2->value.op.op2; var_on_left = true; } else { e = expr2->value.op.op2; if (e->expr_type == EXPR_FUNCTION && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION) e = e->value.function.actual->expr; gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var); expr2 = expr2->value.op.op1; var_on_left = false; } gfc_conv_expr (&rse, expr2); gfc_add_block_to_block (&block, &rse.pre); } else { gcc_assert (expr2->expr_type == EXPR_FUNCTION); switch (expr2->value.function.isym->generic_id) { case GFC_ISYM_MIN: op = MIN_EXPR; break; case GFC_ISYM_MAX: op = MAX_EXPR; break; case GFC_ISYM_IAND: op = BIT_AND_EXPR; break; case GFC_ISYM_IOR: op = BIT_IOR_EXPR; break; case GFC_ISYM_IEOR: op = BIT_XOR_EXPR; break; default: gcc_unreachable (); } e = expr2->value.function.actual->expr; gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var); gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); gfc_add_block_to_block (&block, &rse.pre); if (expr2->value.function.actual->next->next != NULL) { tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); gfc_actual_arglist *arg; gfc_add_modify_expr (&block, accum, rse.expr); for (arg = expr2->value.function.actual->next->next; arg; arg = arg->next) { gfc_init_block (&rse.pre); gfc_conv_expr (&rse, arg->expr); gfc_add_block_to_block (&block, &rse.pre); x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr); gfc_add_modify_expr (&block, accum, x); } rse.expr = accum; } expr2 = expr2->value.function.actual->next->expr; } lhsaddr = save_expr (lhsaddr); rhs = gfc_evaluate_now (rse.expr, &block); x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr)); if (var_on_left) x = fold_build2 (op, TREE_TYPE (rhs), x, rhs); else x = fold_build2 (op, TREE_TYPE (rhs), rhs, x); if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE && TREE_CODE (type) != COMPLEX_TYPE) x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x); x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); gfc_add_expr_to_block (&block, x); gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); return gfc_finish_block (&block); }
static void gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) { gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; gfc_symbol init_val_sym, outer_sym, intrinsic_sym; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt; locus old_loc = gfc_current_locus; const char *iname; try t; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; /* Create a fake symbol for init value. */ memset (&init_val_sym, 0, sizeof (init_val_sym)); init_val_sym.ns = sym->ns; init_val_sym.name = sym->name; init_val_sym.ts = sym->ts; init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); init_val_sym.backend_decl = backend_decl; /* Create a fake symbol for the outer array reference. */ outer_sym = *sym; outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL); /* Create fake symtrees for it. */ symtree1 = gfc_new_symtree (&root1, sym->name); symtree1->n.sym = sym; gcc_assert (symtree1 == root1); symtree2 = gfc_new_symtree (&root2, sym->name); symtree2->n.sym = &init_val_sym; gcc_assert (symtree2 == root2); symtree3 = gfc_new_symtree (&root3, sym->name); symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); /* Create expressions. */ e1 = gfc_get_expr (); e1->expr_type = EXPR_VARIABLE; e1->where = where; e1->symtree = symtree1; e1->ts = sym->ts; e1->ref = ref = gfc_get_ref (); ref->u.ar.where = where; ref->u.ar.as = sym->as; ref->u.ar.type = AR_FULL; ref->u.ar.dimen = 0; t = gfc_resolve_expr (e1); gcc_assert (t == SUCCESS); e2 = gfc_get_expr (); e2->expr_type = EXPR_VARIABLE; e2->where = where; e2->symtree = symtree2; e2->ts = sym->ts; t = gfc_resolve_expr (e2); gcc_assert (t == SUCCESS); e3 = gfc_copy_expr (e1); e3->symtree = symtree3; t = gfc_resolve_expr (e3); gcc_assert (t == SUCCESS); iname = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: case MINUS_EXPR: e4 = gfc_add (e3, e1); break; case MULT_EXPR: e4 = gfc_multiply (e3, e1); break; case TRUTH_ANDIF_EXPR: e4 = gfc_and (e3, e1); break; case TRUTH_ORIF_EXPR: e4 = gfc_or (e3, e1); break; case EQ_EXPR: e4 = gfc_eqv (e3, e1); break; case NE_EXPR: e4 = gfc_neqv (e3, e1); break; case MIN_EXPR: iname = "min"; break; case MAX_EXPR: iname = "max"; break; case BIT_AND_EXPR: iname = "iand"; break; case BIT_IOR_EXPR: iname = "ior"; break; case BIT_XOR_EXPR: iname = "ieor"; break; default: gcc_unreachable (); } if (iname != NULL) { memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); intrinsic_sym.ns = sym->ns; intrinsic_sym.name = iname; intrinsic_sym.ts = sym->ts; intrinsic_sym.attr.referenced = 1; intrinsic_sym.attr.intrinsic = 1; intrinsic_sym.attr.function = 1; intrinsic_sym.result = &intrinsic_sym; intrinsic_sym.declared_at = where; symtree4 = gfc_new_symtree (&root4, iname); symtree4->n.sym = &intrinsic_sym; gcc_assert (symtree4 == root4); e4 = gfc_get_expr (); e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); e4->value.function.actual->next->expr = e1; } /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ e1 = gfc_copy_expr (e1); e3 = gfc_copy_expr (e3); t = gfc_resolve_expr (e4); gcc_assert (t == SUCCESS); /* Create the init statement list. */ pushlevel (0); stmt = gfc_trans_assignment (e1, e2, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_INIT (c) = stmt; /* Create the merge statement list. */ pushlevel (0); stmt = gfc_trans_assignment (e3, e4, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; /* And stick the placeholder VAR_DECL into the clause as well. */ OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; gfc_current_locus = old_loc; gfc_free_expr (e1); gfc_free_expr (e2); gfc_free_expr (e3); gfc_free_expr (e4); gfc_free (symtree1); gfc_free (symtree2); gfc_free (symtree3); if (symtree4) gfc_free (symtree4); gfc_free_array_spec (outer_sym.as); } static tree gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, enum tree_code reduction_code, locus where) { for (; namelist != NULL; namelist = namelist->next) if (namelist->sym->attr.referenced) { tree t = gfc_trans_omp_variable (namelist->sym); if (t != error_mark_node) { tree node = build_omp_clause (OMP_CLAUSE_REDUCTION); OMP_CLAUSE_DECL (node) = t; OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code; if (namelist->sym->attr.dimension) gfc_trans_omp_array_reduction (node, namelist->sym, where); list = gfc_trans_add_clause (node, list); } } return list; } static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where) { tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses; int list; enum omp_clause_code clause_code; gfc_se se; if (clauses == NULL) return NULL_TREE; for (list = 0; list < OMP_LIST_NUM; list++) { gfc_namelist *n = clauses->lists[list]; if (n == NULL) continue; if (list >= OMP_LIST_REDUCTION_FIRST && list <= OMP_LIST_REDUCTION_LAST) { enum tree_code reduction_code; switch (list) { case OMP_LIST_PLUS: reduction_code = PLUS_EXPR; break; case OMP_LIST_MULT: reduction_code = MULT_EXPR; break; case OMP_LIST_SUB: reduction_code = MINUS_EXPR; break; case OMP_LIST_AND: reduction_code = TRUTH_ANDIF_EXPR; break; case OMP_LIST_OR: reduction_code = TRUTH_ORIF_EXPR; break; case OMP_LIST_EQV: reduction_code = EQ_EXPR; break; case OMP_LIST_NEQV: reduction_code = NE_EXPR; break; case OMP_LIST_MAX: reduction_code = MAX_EXPR; break; case OMP_LIST_MIN: reduction_code = MIN_EXPR; break; case OMP_LIST_IAND: reduction_code = BIT_AND_EXPR; break; case OMP_LIST_IOR: reduction_code = BIT_IOR_EXPR; break; case OMP_LIST_IEOR: reduction_code = BIT_XOR_EXPR; break; default: gcc_unreachable (); } old_clauses = omp_clauses; omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, where); continue; } switch (list) { case OMP_LIST_PRIVATE: clause_code = OMP_CLAUSE_PRIVATE; goto add_clause; case OMP_LIST_SHARED: clause_code = OMP_CLAUSE_SHARED; goto add_clause; case OMP_LIST_FIRSTPRIVATE: clause_code = OMP_CLAUSE_FIRSTPRIVATE; goto add_clause; case OMP_LIST_LASTPRIVATE: clause_code = OMP_CLAUSE_LASTPRIVATE; goto add_clause; case OMP_LIST_COPYIN: clause_code = OMP_CLAUSE_COPYIN; goto add_clause; case OMP_LIST_COPYPRIVATE: clause_code = OMP_CLAUSE_COPYPRIVATE; /* FALLTHROUGH */ add_clause: omp_clauses = gfc_trans_omp_variable_list (clause_code, n, omp_clauses); break; default: break; } } if (clauses->if_expr) { tree if_var; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->if_expr); gfc_add_block_to_block (block, &se.pre); if_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (OMP_CLAUSE_IF); OMP_CLAUSE_IF_EXPR (c) = if_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->num_threads) { tree num_threads; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->num_threads); gfc_add_block_to_block (block, &se.pre); num_threads = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (OMP_CLAUSE_NUM_THREADS); OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } chunk_size = NULL_TREE; if (clauses->chunk_size) { gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->chunk_size); gfc_add_block_to_block (block, &se.pre); chunk_size = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); } if (clauses->sched_kind != OMP_SCHED_NONE) { c = build_omp_clause (OMP_CLAUSE_SCHEDULE); OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; switch (clauses->sched_kind) { case OMP_SCHED_STATIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; break; case OMP_SCHED_DYNAMIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; break; case OMP_SCHED_GUIDED: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; break; case OMP_SCHED_RUNTIME: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { c = build_omp_clause (OMP_CLAUSE_DEFAULT); switch (clauses->default_sharing) { case OMP_DEFAULT_NONE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; break; case OMP_DEFAULT_SHARED: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; break; case OMP_DEFAULT_PRIVATE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->nowait) { c = build_omp_clause (OMP_CLAUSE_NOWAIT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->ordered) { c = build_omp_clause (OMP_CLAUSE_ORDERED); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } return omp_clauses; }
static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where) { tree omp_clauses = NULL_TREE, chunk_size, c; int list; enum omp_clause_code clause_code; gfc_se se; if (clauses == NULL) return NULL_TREE; for (list = 0; list < OMP_LIST_NUM; list++) { gfc_namelist *n = clauses->lists[list]; if (n == NULL) continue; if (list >= OMP_LIST_REDUCTION_FIRST && list <= OMP_LIST_REDUCTION_LAST) { enum tree_code reduction_code; switch (list) { case OMP_LIST_PLUS: reduction_code = PLUS_EXPR; break; case OMP_LIST_MULT: reduction_code = MULT_EXPR; break; case OMP_LIST_SUB: reduction_code = MINUS_EXPR; break; case OMP_LIST_AND: reduction_code = TRUTH_ANDIF_EXPR; break; case OMP_LIST_OR: reduction_code = TRUTH_ORIF_EXPR; break; case OMP_LIST_EQV: reduction_code = EQ_EXPR; break; case OMP_LIST_NEQV: reduction_code = NE_EXPR; break; case OMP_LIST_MAX: reduction_code = MAX_EXPR; break; case OMP_LIST_MIN: reduction_code = MIN_EXPR; break; case OMP_LIST_IAND: reduction_code = BIT_AND_EXPR; break; case OMP_LIST_IOR: reduction_code = BIT_IOR_EXPR; break; case OMP_LIST_IEOR: reduction_code = BIT_XOR_EXPR; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, where); continue; } switch (list) { case OMP_LIST_PRIVATE: clause_code = OMP_CLAUSE_PRIVATE; goto add_clause; case OMP_LIST_SHARED: clause_code = OMP_CLAUSE_SHARED; goto add_clause; case OMP_LIST_FIRSTPRIVATE: clause_code = OMP_CLAUSE_FIRSTPRIVATE; goto add_clause; case OMP_LIST_LASTPRIVATE: clause_code = OMP_CLAUSE_LASTPRIVATE; goto add_clause; case OMP_LIST_COPYIN: clause_code = OMP_CLAUSE_COPYIN; goto add_clause; case OMP_LIST_COPYPRIVATE: clause_code = OMP_CLAUSE_COPYPRIVATE; /* FALLTHROUGH */ add_clause: omp_clauses = gfc_trans_omp_variable_list (clause_code, n, omp_clauses); break; default: break; } } if (clauses->if_expr) { tree if_var; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->if_expr); gfc_add_block_to_block (block, &se.pre); if_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF); OMP_CLAUSE_IF_EXPR (c) = if_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->num_threads) { tree num_threads; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->num_threads); gfc_add_block_to_block (block, &se.pre); num_threads = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS); OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } chunk_size = NULL_TREE; if (clauses->chunk_size) { gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->chunk_size); gfc_add_block_to_block (block, &se.pre); chunk_size = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); } if (clauses->sched_kind != OMP_SCHED_NONE) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE); OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; switch (clauses->sched_kind) { case OMP_SCHED_STATIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; break; case OMP_SCHED_DYNAMIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; break; case OMP_SCHED_GUIDED: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; break; case OMP_SCHED_RUNTIME: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; break; case OMP_SCHED_AUTO: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT); switch (clauses->default_sharing) { case OMP_DEFAULT_NONE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; break; case OMP_DEFAULT_SHARED: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; break; case OMP_DEFAULT_PRIVATE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; break; case OMP_DEFAULT_FIRSTPRIVATE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->nowait) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->ordered) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->untied) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->collapse) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE); OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } return omp_clauses; }
static void gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) { gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; gfc_symbol init_val_sym, outer_sym, intrinsic_sym; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt; locus old_loc = gfc_current_locus; const char *iname; gfc_try t; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; /* Create a fake symbol for init value. */ memset (&init_val_sym, 0, sizeof (init_val_sym)); init_val_sym.ns = sym->ns; init_val_sym.name = sym->name; init_val_sym.ts = sym->ts; init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); init_val_sym.backend_decl = backend_decl; /* Create a fake symbol for the outer array reference. */ outer_sym = *sym; outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL); /* Create fake symtrees for it. */ symtree1 = gfc_new_symtree (&root1, sym->name); symtree1->n.sym = sym; gcc_assert (symtree1 == root1); symtree2 = gfc_new_symtree (&root2, sym->name); symtree2->n.sym = &init_val_sym; gcc_assert (symtree2 == root2); symtree3 = gfc_new_symtree (&root3, sym->name); symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); /* Create expressions. */ e1 = gfc_get_expr (); e1->expr_type = EXPR_VARIABLE; e1->where = where; e1->symtree = symtree1; e1->ts = sym->ts; e1->ref = ref = gfc_get_ref (); ref->type = REF_ARRAY; ref->u.ar.where = where; ref->u.ar.as = sym->as; ref->u.ar.type = AR_FULL; ref->u.ar.dimen = 0; t = gfc_resolve_expr (e1); gcc_assert (t == SUCCESS); e2 = gfc_get_expr (); e2->expr_type = EXPR_VARIABLE; e2->where = where; e2->symtree = symtree2; e2->ts = sym->ts; t = gfc_resolve_expr (e2); gcc_assert (t == SUCCESS); e3 = gfc_copy_expr (e1); e3->symtree = symtree3; t = gfc_resolve_expr (e3); gcc_assert (t == SUCCESS); iname = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: case MINUS_EXPR: e4 = gfc_add (e3, e1); break; case MULT_EXPR: e4 = gfc_multiply (e3, e1); break; case TRUTH_ANDIF_EXPR: e4 = gfc_and (e3, e1); break; case TRUTH_ORIF_EXPR: e4 = gfc_or (e3, e1); break; case EQ_EXPR: e4 = gfc_eqv (e3, e1); break; case NE_EXPR: e4 = gfc_neqv (e3, e1); break; case MIN_EXPR: iname = "min"; break; case MAX_EXPR: iname = "max"; break; case BIT_AND_EXPR: iname = "iand"; break; case BIT_IOR_EXPR: iname = "ior"; break; case BIT_XOR_EXPR: iname = "ieor"; break; default: gcc_unreachable (); } if (iname != NULL) { memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); intrinsic_sym.ns = sym->ns; intrinsic_sym.name = iname; intrinsic_sym.ts = sym->ts; intrinsic_sym.attr.referenced = 1; intrinsic_sym.attr.intrinsic = 1; intrinsic_sym.attr.function = 1; intrinsic_sym.result = &intrinsic_sym; intrinsic_sym.declared_at = where; symtree4 = gfc_new_symtree (&root4, iname); symtree4->n.sym = &intrinsic_sym; gcc_assert (symtree4 == root4); e4 = gfc_get_expr (); e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); e4->value.function.actual->next->expr = e1; } /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ e1 = gfc_copy_expr (e1); e3 = gfc_copy_expr (e3); t = gfc_resolve_expr (e4); gcc_assert (t == SUCCESS); /* Create the init statement list. */ pushlevel (0); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be allocated with the same bounds as the outer var. */ tree type = TREE_TYPE (decl), rank, size, esize, ptr; stmtblock_t block; gfc_start_block (&block); gfc_add_modify (&block, decl, outer_sym.backend_decl); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (decl, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (decl, rank)); size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_stride_get (decl, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), size, NULL, NULL); gfc_conv_descriptor_data_set (&block, decl, ptr); gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false)); stmt = gfc_finish_block (&block); } else stmt = gfc_trans_assignment (e1, e2, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_INIT (c) = stmt; /* Create the merge statement list. */ pushlevel (0); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be deallocated afterwards. */ stmtblock_t block; gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false)); gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl)); stmt = gfc_finish_block (&block); } else stmt = gfc_trans_assignment (e3, e4, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; /* And stick the placeholder VAR_DECL into the clause as well. */ OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; gfc_current_locus = old_loc; gfc_free_expr (e1); gfc_free_expr (e2); gfc_free_expr (e3); gfc_free_expr (e4); gfc_free (symtree1); gfc_free (symtree2); gfc_free (symtree3); if (symtree4) gfc_free (symtree4); gfc_free_array_spec (outer_sym.as); }
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); }
/* Allocate memory, using an optional status argument. This function follows the following pseudo-code: void * allocate (size_t size, integer_type* stat) { void *newmem; if (stat) *stat = 0; newmem = malloc (MAX (size, 1)); if (newmem == NULL) { if (stat) *stat = LIBERROR_ALLOCATION; else runtime_error ("Allocation would exceed memory limit"); } return newmem; } */ tree gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) { stmtblock_t alloc_block; tree res, tmp, msg, cond; tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE; /* Evaluate size only once, and make sure it has the right type. */ size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* Create a variable to hold the result. */ res = gfc_create_var (prvoid_type_node, NULL); /* Set the optional status variable to zero. */ if (status != NULL_TREE && !integer_zerop (status)) { 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, fold_build2_loc (input_location, NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } /* The allocation itself. */ gfc_start_block (&alloc_block); gfc_add_modify (&alloc_block, res, fold_convert (prvoid_type_node, build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MALLOC], 1, fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1))))); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Allocation would exceed memory limit")); tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg); if (status != NULL_TREE && !integer_zerop (status)) { /* Set the status variable if it's present. */ tree tmp2; cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), build_int_cst (status_type, LIBERROR_ALLOCATION)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, tmp2); } tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, res, build_int_cst (prvoid_type_node, 0)), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block)); return res; }
/* Allocate memory, using an optional status argument. This function follows the following pseudo-code: void * allocate (size_t size, integer_type* stat) { void *newmem; if (stat) *stat = 0; // The only time this can happen is the size wraps around. if (size < 0) { if (stat) { *stat = LIBERROR_ALLOCATION; newmem = NULL; } else runtime_error ("Attempt to allocate negative amount of memory. " "Possible integer overflow"); } else { newmem = malloc (MAX (size, 1)); if (newmem == NULL) { if (stat) *stat = LIBERROR_ALLOCATION; else runtime_error ("Out of memory"); } } return newmem; } */ tree gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) { stmtblock_t alloc_block; tree res, tmp, error, msg, cond; tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE; /* Evaluate size only once, and make sure it has the right type. */ size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); /* Create a variable to hold the result. */ res = gfc_create_var (prvoid_type_node, NULL); /* Set the optional status variable to zero. */ if (status != NULL_TREE && !integer_zerop (status)) { tmp = fold_build2 (MODIFY_EXPR, status_type, fold_build1 (INDIRECT_REF, status_type, status), build_int_cst (status_type, 0)); tmp = fold_build3 (COND_EXPR, void_type_node, fold_build2 (NE_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } /* Generate the block of code handling (size < 0). */ msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Attempt to allocate negative amount of memory. " "Possible integer overflow")); error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error, 1, msg); if (status != NULL_TREE && !integer_zerop (status)) { /* Set the status variable if it's present. */ stmtblock_t set_status_block; gfc_start_block (&set_status_block); gfc_add_modify (&set_status_block, fold_build1 (INDIRECT_REF, status_type, status), build_int_cst (status_type, LIBERROR_ALLOCATION)); gfc_add_modify (&set_status_block, res, build_int_cst (prvoid_type_node, 0)); tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); error = fold_build3 (COND_EXPR, void_type_node, tmp, error, gfc_finish_block (&set_status_block)); } /* The allocation itself. */ gfc_start_block (&alloc_block); gfc_add_modify (&alloc_block, res, fold_convert (prvoid_type_node, build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MALLOC], 1, fold_build2 (MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1))))); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Out of memory")); tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg); if (status != NULL_TREE && !integer_zerop (status)) { /* Set the status variable if it's present. */ tree tmp2; cond = fold_build2 (EQ_EXPR, boolean_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp2 = fold_build2 (MODIFY_EXPR, status_type, fold_build1 (INDIRECT_REF, status_type, status), build_int_cst (status_type, LIBERROR_ALLOCATION)); tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, tmp2); } tmp = fold_build3 (COND_EXPR, void_type_node, fold_build2 (EQ_EXPR, boolean_type_node, res, build_int_cst (prvoid_type_node, 0)), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); cond = fold_build2 (LT_EXPR, boolean_type_node, size, build_int_cst (TREE_TYPE (size), 0)); tmp = fold_build3 (COND_EXPR, void_type_node, cond, error, gfc_finish_block (&alloc_block)); gfc_add_expr_to_block (block, tmp); return res; }