diff options
Diffstat (limited to 'gcc')
27 files changed, 1325 insertions, 69 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bbcb20bafcc..07a734e7729 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,11 +1,47 @@ +2011-10-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (DECL_LOOP_PARM_P): New flag. + (DECL_INDUCTION_VAR): New macro. + (SET_DECL_INDUCTION_VAR): Likewise. + * gcc-interface/gigi.h (convert_to_index_type): Declare. + (gnat_invariant_expr): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: If this is a loop + parameter, set DECL_LOOP_PARM_P on it. + * gcc-interface/misc.c (gnat_print_decl) <VAR_DECL>: If DECL_LOOP_PARM_P + is set, print DECL_INDUCTION_VAR instead of DECL_RENAMED_OBJECT. + * gcc-interface/trans.c (gnu_loop_label_stack): Delete. + (struct range_check_info_d): New type. + (struct loop_info_d): Likewise. + (gnu_loop_stack): New stack. + (Identifier_to_gnu): Set TREE_READONLY flag on the first dereference + built for a by-double-ref read-only parameter. If DECL_LOOP_PARM_P + is set, do not test DECL_RENAMED_OBJECT. + (push_range_check_info): New function. + (Loop_Statement_to_gnu): Push a new struct loop_info_d instead of just + the label. Reference the label and the iteration variable from it. + Build the special induction variable in the unsigned version of the + size type, if it is larger than the base type. And attach it to the + iteration variable if the latter isn't by-ref. In the iteration scheme + case, initialize the invariant conditions in front of the loop if + deemed profitable. Use gnu_loop_stack. + (gnat_to_gnu) <N_Exit_Statement>: Use gnu_loop_stack. + <N_Raise_Constraint_Error>: Always process the reason. In the range + check and related cases, and if loop unswitching is enabled, compute + invariant conditions and push this information onto the stack. + Do not translate again the condition if it has been already translated. + * gcc-interface/utils.c (record_global_renaming_pointer): Assert that + DECL_LOOP_PARM_P isn't set. + (convert_to_index_type): New function. + * gcc-interface/utils2.c (build_binary_op) <ARRAY_REF>: Use it in order + to convert the index from the base index type to sizetype. + (gnat_invariant_expr): New function. + 2011-10-11 Michael Meissner <meissner@linux.vnet.ibm.com> * gcc-interface/utils.c (def_builtin_1): Delete old interface with two parallel arrays to hold standard builtin declarations, and replace it with a function based interface that can support - creating builtins on the fly in the future. Change all uses, and - poison the old names. Make sure 0 is not a legitimate builtin - index. + creating builtins on the fly in the future. * gcc-interface/trans.c (Exception_Handler_to_gnu_zcx): Ditto. (gnat_to_gnu): Ditto. diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index d10fcf0ad92..c408de30296 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -355,6 +355,9 @@ do { \ /* Nonzero in a DECL if it is made for a pointer that can never be null. */ #define DECL_CAN_NEVER_BE_NULL_P(NODE) DECL_LANG_FLAG_2 (NODE) +/* Nonzero in a VAR_DECL if it is made for a loop parameter. */ +#define DECL_LOOP_PARM_P(NODE) DECL_LANG_FLAG_3 (VAR_DECL_CHECK (NODE)) + /* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ #define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) @@ -409,9 +412,16 @@ do { \ || (DECL_ORIGINAL_FIELD (FIELD1) \ && (DECL_ORIGINAL_FIELD (FIELD1) == DECL_ORIGINAL_FIELD (FIELD2)))) -/* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a - renaming pointer, otherwise 0. Note that this object is guaranteed to - be protected against multiple evaluations. */ +/* In a VAR_DECL with the DECL_LOOP_PARM_P flag set, points to the special + induction variable that is built under certain circumstances, if any. */ +#define DECL_INDUCTION_VAR(NODE) \ + GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) +#define SET_DECL_INDUCTION_VAR(NODE, X) \ + SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) + +/* In a VAR_DECL without the DECL_LOOP_PARM_P flag set and that is a renaming + pointer, points to the object being renamed, if any. Note that this object + is guaranteed to be protected against multiple evaluations. */ #define DECL_RENAMED_OBJECT(NODE) \ GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) #define SET_DECL_RENAMED_OBJECT(NODE, X) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index feb353ba783..81f891fee63 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -1431,10 +1431,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TREE_ADDRESSABLE (gnu_decl) = 1; } + /* If this is a loop parameter, set the corresponding flag. */ + else if (kind == E_Loop_Parameter) + DECL_LOOP_PARM_P (gnu_decl) = 1; + /* If this is a renaming pointer, attach the renamed object to it and register it if we are at the global level. Note that an external constant is at the global level. */ - if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) + else if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) { SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); if ((!definition && kind == E_Constant) || global_bindings_p ()) diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index f7f9b09272e..143926160ac 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -492,6 +492,10 @@ extern bool fntype_same_flags_p (const_tree, tree, bool, bool, bool); not permitted by the language being compiled. */ extern tree convert (tree type, tree expr); +/* Create an expression whose value is that of EXPR converted to the common + index type, which is sizetype. */ +extern tree convert_to_index_type (tree expr); + /* Routines created solely for the tree translator's sake. Their prototypes can be changed as desired. */ @@ -916,6 +920,11 @@ extern tree gnat_protect_expr (tree exp); through something we don't know how to stabilize. */ extern tree gnat_stabilize_reference (tree ref, bool force, bool *success); +/* If EXPR is an expression that is invariant in the current function, in the + sense that it can be evaluated anywhere in the function and any number of + times, return EXPR or an equivalent expression. Otherwise return NULL. */ +extern tree gnat_invariant_expr (tree expr); + /* Implementation of the builtin_function langhook. */ extern tree gnat_builtin_function (tree decl); diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index f651af5afe3..9b667125225 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -394,8 +394,12 @@ gnat_print_decl (FILE *file, tree node, int indent) break; case VAR_DECL: - print_node (file, "renamed object", DECL_RENAMED_OBJECT (node), - indent + 4); + if (DECL_LOOP_PARM_P (node)) + print_node (file, "induction var", DECL_INDUCTION_VAR (node), + indent + 4); + else + print_node (file, "renamed object", DECL_RENAMED_OBJECT (node), + indent + 4); break; default: diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 858810ae4e8..cd84dc7eaf2 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -189,8 +189,33 @@ static GTY(()) VEC(tree,gc) *gnu_return_label_stack; parameters. See processing for N_Subprogram_Body. */ static GTY(()) VEC(tree,gc) *gnu_return_var_stack; -/* Stack of LOOP_STMT nodes. */ -static GTY(()) VEC(tree,gc) *gnu_loop_label_stack; +/* Structure used to record information for a range check. */ +struct GTY(()) range_check_info_d { + tree low_bound; + tree high_bound; + tree type; + tree invariant_cond; +}; + +typedef struct range_check_info_d *range_check_info; + +DEF_VEC_P(range_check_info); +DEF_VEC_ALLOC_P(range_check_info,gc); + +/* Structure used to record information for a loop. */ +struct GTY(()) loop_info_d { + tree label; + tree loop_var; + VEC(range_check_info,gc) *checks; +}; + +typedef struct loop_info_d *loop_info; + +DEF_VEC_P(loop_info); +DEF_VEC_ALLOC_P(loop_info,gc); + +/* Stack of loop_info structures associated with LOOP_STMT nodes. */ +static GTY(()) VEC(loop_info,gc) *gnu_loop_stack; /* The stacks for N_{Push,Pop}_*_Label. */ static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack; @@ -1008,6 +1033,9 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); if (TREE_CODE (gnu_result) == INDIRECT_REF) TREE_THIS_NOTRAP (gnu_result) = 1; + + if (read_only) + TREE_READONLY (gnu_result) = 1; } /* If it's a PARM_DECL to foreign convention subprogram, convert it. */ @@ -1024,6 +1052,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) we can reference the renamed object directly, since the renamed expression has been protected against multiple evaluations. */ if (TREE_CODE (gnu_result) == VAR_DECL + && !DECL_LOOP_PARM_P (gnu_result) && DECL_RENAMED_OBJECT (gnu_result) && (!DECL_RENAMING_GLOBAL_P (gnu_result) || global_bindings_p ())) gnu_result = DECL_RENAMED_OBJECT (gnu_result); @@ -2114,6 +2143,44 @@ Case_Statement_to_gnu (Node_Id gnat_node) return gnu_result; } +/* Find out whether VAR is an iteration variable of an enclosing loop in the + current function. If so, push a range_check_info structure onto the stack + of this enclosing loop and return it. Otherwise, return NULL. */ + +static struct range_check_info_d * +push_range_check_info (tree var) +{ + struct loop_info_d *iter = NULL; + unsigned int i; + + if (VEC_empty (loop_info, gnu_loop_stack)) + return NULL; + + while (CONVERT_EXPR_P (var) || TREE_CODE (var) == VIEW_CONVERT_EXPR) + var = TREE_OPERAND (var, 0); + + if (TREE_CODE (var) != VAR_DECL) + return NULL; + + if (decl_function_context (var) != current_function_decl) + return NULL; + + for (i = VEC_length (loop_info, gnu_loop_stack) - 1; + VEC_iterate (loop_info, gnu_loop_stack, i, iter); + i--) + if (var == iter->loop_var) + break; + + if (iter) + { + struct range_check_info_d *rci = ggc_alloc_range_check_info_d (); + VEC_safe_push (range_check_info, gc, iter->checks, rci); + return rci; + } + + return NULL; +} + /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is false, or the maximum value if MAX is true, of TYPE. */ @@ -2181,10 +2248,15 @@ static tree Loop_Statement_to_gnu (Node_Id gnat_node) { const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); + struct loop_info_d *gnu_loop_info = ggc_alloc_cleared_loop_info_d (); tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE); tree gnu_loop_label = create_artificial_label (input_location); - tree gnu_cond_expr = NULL_TREE, gnu_result; + tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE; + tree gnu_result; + + /* Push the loop_info structure associated with the LOOP_STMT. */ + VEC_safe_push (loop_info, gc, gnu_loop_stack, gnu_loop_info); /* Set location information for statement and end label. */ set_expr_location_from_node (gnu_loop_stmt, gnat_node); @@ -2192,9 +2264,8 @@ Loop_Statement_to_gnu (Node_Id gnat_node) &DECL_SOURCE_LOCATION (gnu_loop_label)); LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; - /* Save the end label of this LOOP_STMT in a stack so that a corresponding - N_Exit_Statement can find it. */ - VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label); + /* Save the label so that a corresponding N_Exit_Statement can find it. */ + gnu_loop_info->label = gnu_loop_label; /* Set the condition under which the loop must keep going. For the case "LOOP .... END LOOP;" the condition is always true. */ @@ -2214,14 +2285,15 @@ Loop_Statement_to_gnu (Node_Id gnat_node) Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); Entity_Id gnat_type = Etype (gnat_loop_var); tree gnu_type = get_unpadded_type (gnat_type); - tree gnu_low = TYPE_MIN_VALUE (gnu_type); - tree gnu_high = TYPE_MAX_VALUE (gnu_type); tree gnu_base_type = get_base_type (gnu_type); tree gnu_one_node = convert (gnu_base_type, integer_one_node); tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt; enum tree_code update_code, test_code, shift_code; bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false; + gnu_low = TYPE_MIN_VALUE (gnu_type); + gnu_high = TYPE_MAX_VALUE (gnu_type); + /* We must disable modulo reduction for the iteration variable, if any, in order for the loop comparison to be effective. */ if (reverse) @@ -2296,17 +2368,20 @@ Loop_Statement_to_gnu (Node_Id gnat_node) ; /* Otherwise, use the do-while form with the help of a special - induction variable in the (unsigned version of) the base - type, in order to have wrap-around arithmetics for it. */ + induction variable in the unsigned version of the base type + or the unsigned version of the size type, whichever is the + largest, in order to have wrap-around arithmetics for it. */ else { - if (!TYPE_UNSIGNED (gnu_base_type)) - { - gnu_base_type = gnat_unsigned_type (gnu_base_type); - gnu_first = convert (gnu_base_type, gnu_first); - gnu_last = convert (gnu_base_type, gnu_last); - gnu_one_node = convert (gnu_base_type, integer_one_node); - } + if (TYPE_PRECISION (gnu_base_type) + > TYPE_PRECISION (size_type_node)) + gnu_base_type = gnat_unsigned_type (gnu_base_type); + else + gnu_base_type = size_type_node; + + gnu_first = convert (gnu_base_type, gnu_first); + gnu_last = convert (gnu_base_type, gnu_last); + gnu_one_node = convert (gnu_base_type, integer_one_node); use_iv = true; } @@ -2379,6 +2454,12 @@ Loop_Statement_to_gnu (Node_Id gnat_node) gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); if (DECL_BY_REF_P (gnu_loop_var)) gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); + else if (use_iv) + { + gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var)); + SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv); + } + gnu_loop_info->loop_var = gnu_loop_var; /* Do all the arithmetics in the base type. */ gnu_loop_var = convert (gnu_base_type, gnu_loop_var); @@ -2437,6 +2518,45 @@ Loop_Statement_to_gnu (Node_Id gnat_node) the LOOP_STMT to it, finish it and make it the "loop". */ if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme))) { + struct range_check_info_d *rci; + unsigned n_checks = VEC_length (range_check_info, gnu_loop_info->checks); + unsigned int i; + + /* First, if we have computed a small number of invariant conditions for + range checks applied to the iteration variable, then initialize these + conditions in front of the loop. Otherwise, leave them set to True. + + ??? The heuristics need to be improved, by taking into account the + following datapoints: + - loop unswitching is disabled for big loops. The cap is the + parameter PARAM_MAX_UNSWITCH_INSNS (50). + - loop unswitching can only be applied a small number of times + to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3). + - the front-end quickly generates useless or redundant checks + that can be entirely optimized away in the end. */ + if (1 <= n_checks && n_checks <= 4) + for (i = 0; + VEC_iterate (range_check_info, gnu_loop_info->checks, i, rci); + i++) + { + tree low_ok + = build_binary_op (GE_EXPR, boolean_type_node, + convert (rci->type, gnu_low), + rci->low_bound); + tree high_ok + = build_binary_op (LE_EXPR, boolean_type_node, + convert (rci->type, gnu_high), + rci->high_bound); + tree range_ok + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + low_ok, high_ok); + + TREE_OPERAND (rci->invariant_cond, 0) + = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok); + + add_stmt_with_node_force (rci->invariant_cond, gnat_node); + } + add_stmt (gnu_loop_stmt); gnat_poplevel (); gnu_loop_stmt = end_stmt_group (); @@ -2453,7 +2573,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node) else gnu_result = gnu_loop_stmt; - VEC_pop (tree, gnu_loop_label_stack); + VEC_pop (loop_info, gnu_loop_stack); return gnu_result; } @@ -5588,7 +5708,7 @@ gnat_to_gnu (Node_Id gnat_node) ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), (Present (Name (gnat_node)) ? get_gnu_tree (Entity (Name (gnat_node))) - : VEC_last (tree, gnu_loop_label_stack))); + : VEC_last (loop_info, gnu_loop_stack)->label)); break; case N_Return_Statement: @@ -6174,7 +6294,11 @@ gnat_to_gnu (Node_Id gnat_node) case N_Raise_Storage_Error: { const int reason = UI_To_Int (Reason (gnat_node)); - const Node_Id cond = Condition (gnat_node); + const Node_Id gnat_cond = Condition (gnat_node); + const bool with_extra_info = Exception_Extra_Info + && !No_Exception_Handlers_Set () + && !get_exception_label (kind); + tree gnu_cond = NULL_TREE; if (type_annotate_only) { @@ -6184,43 +6308,66 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (Exception_Extra_Info - && !No_Exception_Handlers_Set () - && !get_exception_label (kind) - && VOID_TYPE_P (gnu_result_type) - && Present (cond)) - switch (reason) - { - case CE_Access_Check_Failed: + switch (reason) + { + case CE_Access_Check_Failed: + if (with_extra_info) gnu_result = build_call_raise_column (reason, gnat_node); - break; + break; - case CE_Index_Check_Failed: - case CE_Range_Check_Failed: - case CE_Invalid_Data: - if (Nkind (cond) == N_Op_Not - && Nkind (Right_Opnd (cond)) == N_In - && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range) - { - Node_Id op = Right_Opnd (cond); /* N_In node */ - Node_Id index = Left_Opnd (op); - Node_Id range = Right_Opnd (op); - Node_Id type = Etype (index); - if (Is_Type (type) - && Known_Esize (type) - && UI_To_Int (Esize (type)) <= 32) - gnu_result - = build_call_raise_range (reason, gnat_node, - gnat_to_gnu (index), - gnat_to_gnu - (Low_Bound (range)), - gnat_to_gnu - (High_Bound (range))); - } - break; + case CE_Index_Check_Failed: + case CE_Range_Check_Failed: + case CE_Invalid_Data: + if (Present (gnat_cond) + && Nkind (gnat_cond) == N_Op_Not + && Nkind (Right_Opnd (gnat_cond)) == N_In + && Nkind (Right_Opnd (Right_Opnd (gnat_cond))) == N_Range) + { + Node_Id gnat_index = Left_Opnd (Right_Opnd (gnat_cond)); + Node_Id gnat_type = Etype (gnat_index); + Node_Id gnat_range = Right_Opnd (Right_Opnd (gnat_cond)); + tree gnu_index = gnat_to_gnu (gnat_index); + tree gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range)); + tree gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range)); + struct range_check_info_d *rci; + + if (with_extra_info + && Known_Esize (gnat_type) + && UI_To_Int (Esize (gnat_type)) <= 32) + gnu_result + = build_call_raise_range (reason, gnat_node, gnu_index, + gnu_low_bound, gnu_high_bound); + + /* If loop unswitching is enabled, we try to compute invariant + conditions for checks applied to iteration variables, i.e. + conditions that are both independent of the variable and + necessary in order for the check to fail in the course of + some iteration, and prepend them to the original condition + of the checks. This will make it possible later for the + loop unswitching pass to replace the loop with two loops, + one of which has the checks eliminated and the other has + the original checks reinstated, and a run time selection. + The former loop will be suitable for vectorization. */ + if (flag_unswitch_loops + && (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)) + && (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)) + && (rci = push_range_check_info (gnu_index))) + { + rci->low_bound = gnu_low_bound; + rci->high_bound = gnu_high_bound; + rci->type = gnat_to_gnu_type (gnat_type); + rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node, + boolean_true_node); + gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR, + boolean_type_node, + rci->invariant_cond, + gnat_to_gnu (gnat_cond)); + } + } + break; - default: - break; + default: + break; } if (gnu_result == error_mark_node) @@ -6232,10 +6379,14 @@ gnat_to_gnu (Node_Id gnat_node) the code for the call. Handle a condition, if there is one. */ if (VOID_TYPE_P (gnu_result_type)) { - if (Present (cond)) - gnu_result - = build3 (COND_EXPR, void_type_node, gnat_to_gnu (cond), - gnu_result, alloc_stmt_list ()); + if (Present (gnat_cond)) + { + if (!gnu_cond) + gnu_cond = gnat_to_gnu (gnat_cond); + gnu_result + = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result, + alloc_stmt_list ()); + } } else gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 7c7e7c6c499..c4cfde7e421 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -1771,7 +1771,7 @@ process_attributes (tree decl, struct attrib *attr_list) void record_global_renaming_pointer (tree decl) { - gcc_assert (DECL_RENAMED_OBJECT (decl)); + gcc_assert (!DECL_LOOP_PARM_P (decl) && DECL_RENAMED_OBJECT (decl)); VEC_safe_push (tree, gc, global_renaming_pointers, decl); } @@ -4247,6 +4247,92 @@ convert (tree type, tree expr) gcc_unreachable (); } } + +/* Create an expression whose value is that of EXPR converted to the common + index type, which is sizetype. EXPR is supposed to be in the base type + of the GNAT index type. Calling it is equivalent to doing + + convert (sizetype, expr) + + but we try to distribute the type conversion with the knowledge that EXPR + cannot overflow in its type. This is a best-effort approach and we fall + back to the above expression as soon as difficulties are encountered. + + This is necessary to overcome issues that arise when the GNAT base index + type and the GCC common index type (sizetype) don't have the same size, + which is quite frequent on 64-bit architectures. In this case, and if + the GNAT base index type is signed but the iteration type of the loop has + been forced to unsigned, the loop scalar evolution engine cannot compute + a simple evolution for the general induction variables associated with the + array indices, because it will preserve the wrap-around semantics in the + unsigned type of their "inner" part. As a result, many loop optimizations + are blocked. + + The solution is to use a special (basic) induction variable that is at + least as large as sizetype, and to express the aforementioned general + induction variables in terms of this induction variable, eliminating + the problematic intermediate truncation to the GNAT base index type. + This is possible as long as the original expression doesn't overflow + and if the middle-end hasn't introduced artificial overflows in the + course of the various simplification it can make to the expression. */ + +tree +convert_to_index_type (tree expr) +{ + enum tree_code code = TREE_CODE (expr); + tree type = TREE_TYPE (expr); + + /* If the type is unsigned, overflow is allowed so we cannot be sure that + EXPR doesn't overflow. Keep it simple if optimization is disabled. */ + if (TYPE_UNSIGNED (type) || !optimize) + return convert (sizetype, expr); + + switch (code) + { + case VAR_DECL: + /* The main effect of the function: replace a loop parameter with its + associated special induction variable. */ + if (DECL_LOOP_PARM_P (expr) && DECL_INDUCTION_VAR (expr)) + expr = DECL_INDUCTION_VAR (expr); + break; + + CASE_CONVERT: + { + tree otype = TREE_TYPE (TREE_OPERAND (expr, 0)); + /* Bail out as soon as we suspect some sort of type frobbing. */ + if (TYPE_PRECISION (type) != TYPE_PRECISION (otype) + || TYPE_UNSIGNED (type) != TYPE_UNSIGNED (otype)) + break; + } + + /* ... fall through ... */ + + case NON_LVALUE_EXPR: + return fold_build1 (code, sizetype, + convert_to_index_type (TREE_OPERAND (expr, 0))); + + case PLUS_EXPR: + case MINUS_EXPR: + case MULT_EXPR: + return fold_build2 (code, sizetype, + convert_to_index_type (TREE_OPERAND (expr, 0)), + convert_to_index_type (TREE_OPERAND (expr, 1))); + + case COMPOUND_EXPR: + return fold_build2 (code, sizetype, TREE_OPERAND (expr, 0), + convert_to_index_type (TREE_OPERAND (expr, 1))); + + case COND_EXPR: + return fold_build3 (code, sizetype, TREE_OPERAND (expr, 0), + convert_to_index_type (TREE_OPERAND (expr, 1)), + convert_to_index_type (TREE_OPERAND (expr, 2))); + + default: + break; + } + + return convert (sizetype, expr); +} /* Remove all conversions that are done in EXP. This includes converting from a padded type or to a justified modular type. If TRUE_ADDRESS diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index cf290a397b1..4679ea85f30 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -798,7 +798,7 @@ build_binary_op (enum tree_code op_code, tree result_type, /* Then convert the right operand to its base type. This will prevent unneeded sign conversions when sizetype is wider than integer. */ right_operand = convert (right_base_type, right_operand); - right_operand = convert (sizetype, right_operand); + right_operand = convert_to_index_type (right_operand); modulus = NULL_TREE; break; @@ -2598,3 +2598,88 @@ gnat_stabilize_reference (tree ref, bool force, bool *success) return result; } + +/* If EXPR is an expression that is invariant in the current function, in the + sense that it can be evaluated anywhere in the function and any number of + times, return EXPR or an equivalent expression. Otherwise return NULL. */ + +tree +gnat_invariant_expr (tree expr) +{ + tree type = TREE_TYPE (expr), t; + + STRIP_NOPS (expr); + + while ((TREE_CODE (expr) == CONST_DECL + || (TREE_CODE (expr) == VAR_DECL && TREE_READONLY (expr))) + && decl_function_context (expr) == current_function_decl + && DECL_INITIAL (expr)) + { + expr = DECL_INITIAL (expr); + STRIP_NOPS (expr); + } + + if (TREE_CONSTANT (expr)) + return fold_convert (type, expr); + + t = expr; + + while (true) + { + switch (TREE_CODE (t)) + { + case COMPONENT_REF: + if (TREE_OPERAND (t, 2) != NULL_TREE) + return NULL_TREE; + break; + + case ARRAY_REF: + case ARRAY_RANGE_REF: + if (!TREE_CONSTANT (TREE_OPERAND (t, 1)) + || TREE_OPERAND (t, 2) != NULL_TREE + || TREE_OPERAND (t, 3) != NULL_TREE) + return NULL_TREE; + break; + + case BIT_FIELD_REF: + case VIEW_CONVERT_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + break; + + case INDIRECT_REF: + if (!TREE_READONLY (t) + || TREE_SIDE_EFFECTS (t) + || !TREE_THIS_NOTRAP (t)) + return NULL_TREE; + break; + + default: + goto object; + } + + t = TREE_OPERAND (t, 0); + } + +object: + if (TREE_SIDE_EFFECTS (t)) + return NULL_TREE; + + if (TREE_CODE (t) == CONST_DECL + && (DECL_EXTERNAL (t) + || decl_function_context (t) != current_function_decl)) + return fold_convert (type, expr); + + if (!TREE_READONLY (t)) + return NULL_TREE; + + if (TREE_CODE (t) == PARM_DECL) + return fold_convert (type, expr); + + if (TREE_CODE (t) == VAR_DECL + && (DECL_EXTERNAL (t) + || decl_function_context (t) != current_function_decl)) + return fold_convert (type, expr); + + return NULL_TREE; +} diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 11a3cc6b106..9e8f1f9b952 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2011-10-12 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/vect1.ad[sb]: New test. + * gnat.dg/vect1_pkg.ads: New helper. + * gnat.dg/vect2.ad[sb]: New test. + * gnat.dg/vect2_pkg.ads: New helper. + * gnat.dg/vect3.ad[sb]: New test. + * gnat.dg/vect3_pkg.ads: New helper. + * gnat.dg/vect4.ad[sb]: New test. + * gnat.dg/vect4_pkg.ads: New helper. + * gnat.dg/vect5.ad[sb]: New test. + * gnat.dg/vect5_pkg.ads: New helper. + * gnat.dg/vect6.ad[sb]: New test. + * gnat.dg/vect6_pkg.ads: New helper. + 2011-10-12 H.J. Lu <hongjiu.lu@intel.com> * gcc.target/i386/fma_run_double_1.c: Add -mfpmath=sse. diff --git a/gcc/testsuite/gnat.dg/vect1.adb b/gcc/testsuite/gnat.dg/vect1.adb new file mode 100644 index 00000000000..0bbd9ee86a7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect1.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect1 is + + function "+" (X, Y : Varray) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Varray; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Sarray) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray1) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray2) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray3) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + +end Vect1; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect1.ads b/gcc/testsuite/gnat.dg/vect1.ads new file mode 100644 index 00000000000..48343fc0553 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect1.ads @@ -0,0 +1,42 @@ +with Vect1_Pkg; + +package Vect1 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Integer range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X, Y : Varray) return Varray; + procedure Add (X, Y : not null access Varray; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (1 .. 4) of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X, Y : Sarray) return Sarray; + procedure Add (X, Y : not null access Sarray; R : not null access Sarray); + + + type Darray1 is array (1 .. Vect1_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X, Y : Darray1) return Darray1; + procedure Add (X, Y : not null access Darray1; R : not null access Darray1); + + + type Darray2 is array (Vect1_Pkg.K .. 4) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X, Y : Darray2) return Darray2; + procedure Add (X, Y : not null access Darray2; R : not null access Darray2); + + + type Darray3 is array (Vect1_Pkg.K .. Vect1_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X, Y : Darray3) return Darray3; + procedure Add (X, Y : not null access Darray3; R : not null access Darray3); + +end Vect1; diff --git a/gcc/testsuite/gnat.dg/vect1_pkg.ads b/gcc/testsuite/gnat.dg/vect1_pkg.ads new file mode 100644 index 00000000000..b9fab52b1e2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect1_pkg.ads @@ -0,0 +1,6 @@ +package Vect1_Pkg is + + function K return Integer; + function N return Integer; + +end Vect1_Pkg; diff --git a/gcc/testsuite/gnat.dg/vect2.adb b/gcc/testsuite/gnat.dg/vect2.adb new file mode 100644 index 00000000000..54e0403f135 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect2.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect2 is + + function "+" (X, Y : Varray) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Varray; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Sarray) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray1) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray2) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray3) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + +end Vect2; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect2.ads b/gcc/testsuite/gnat.dg/vect2.ads new file mode 100644 index 00000000000..b5111875924 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect2.ads @@ -0,0 +1,42 @@ +with Vect2_Pkg; + +package Vect2 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Positive range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X, Y : Varray) return Varray; + procedure Add (X, Y : not null access Varray; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (Positive(1) .. Positive(4)) of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X, Y : Sarray) return Sarray; + procedure Add (X, Y : not null access Sarray; R : not null access Sarray); + + + type Darray1 is array (Positive(1) .. Vect2_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X, Y : Darray1) return Darray1; + procedure Add (X, Y : not null access Darray1; R : not null access Darray1); + + + type Darray2 is array (Vect2_Pkg.K .. Positive(4)) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X, Y : Darray2) return Darray2; + procedure Add (X, Y : not null access Darray2; R : not null access Darray2); + + + type Darray3 is array (Vect2_Pkg.K .. Vect2_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X, Y : Darray3) return Darray3; + procedure Add (X, Y : not null access Darray3; R : not null access Darray3); + +end Vect2; diff --git a/gcc/testsuite/gnat.dg/vect2_pkg.ads b/gcc/testsuite/gnat.dg/vect2_pkg.ads new file mode 100644 index 00000000000..804e10caebc --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect2_pkg.ads @@ -0,0 +1,6 @@ +package Vect2_Pkg is + + function K return Positive; + function N return Positive; + +end Vect2_Pkg; diff --git a/gcc/testsuite/gnat.dg/vect3.adb b/gcc/testsuite/gnat.dg/vect3.adb new file mode 100644 index 00000000000..3baa6388e17 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect3.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect3 is + + function "+" (X, Y : Varray) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Varray; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Sarray) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray1) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray2) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + + + function "+" (X, Y : Darray3) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + return R; + end; + + procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y(I); + end loop; + end; + +end Vect3; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect3.ads b/gcc/testsuite/gnat.dg/vect3.ads new file mode 100644 index 00000000000..d78e3c44cff --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect3.ads @@ -0,0 +1,43 @@ +with Vect3_Pkg; + +package Vect3 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Vect3_Pkg.Index_Type range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X, Y : Varray) return Varray; + procedure Add (X, Y : not null access Varray; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (Vect3_Pkg.Index_Type(1) .. Vect3_Pkg.Index_Type(4)) + of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X, Y : Sarray) return Sarray; + procedure Add (X, Y : not null access Sarray; R : not null access Sarray); + + + type Darray1 is array (Vect3_Pkg.Index_Type(1) .. Vect3_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X, Y : Darray1) return Darray1; + procedure Add (X, Y : not null access Darray1; R : not null access Darray1); + + + type Darray2 is array (Vect3_Pkg.K .. Vect3_Pkg.Index_Type(4)) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X, Y : Darray2) return Darray2; + procedure Add (X, Y : not null access Darray2; R : not null access Darray2); + + + type Darray3 is array (Vect3_Pkg.K .. Vect3_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X, Y : Darray3) return Darray3; + procedure Add (X, Y : not null access Darray3; R : not null access Darray3); + +end Vect3; diff --git a/gcc/testsuite/gnat.dg/vect3_pkg.ads b/gcc/testsuite/gnat.dg/vect3_pkg.ads new file mode 100644 index 00000000000..8c926bbcd6a --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect3_pkg.ads @@ -0,0 +1,10 @@ +with System; + +package Vect3_Pkg is + + type Index_Type is mod System.Memory_Size; + + function K return Index_Type; + function N return Index_Type; + +end Vect3_Pkg; diff --git a/gcc/testsuite/gnat.dg/vect4.adb b/gcc/testsuite/gnat.dg/vect4.adb new file mode 100644 index 00000000000..032a7289394 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect4.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect4 is + + function "+" (X : Varray; Y : Long_Float) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Sarray; Y : Long_Float) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray1; Y : Long_Float) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray2; Y : Long_Float) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray3; Y : Long_Float) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + end; + +end Vect4; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect4.ads b/gcc/testsuite/gnat.dg/vect4.ads new file mode 100644 index 00000000000..98df7efeebc --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect4.ads @@ -0,0 +1,42 @@ +with Vect4_Pkg; + +package Vect4 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Integer range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X : Varray; Y : Long_Float) return Varray; + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (1 .. 4) of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X : Sarray; Y : Long_Float) return Sarray; + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray); + + + type Darray1 is array (1 .. Vect4_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X : Darray1; Y : Long_Float) return Darray1; + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1); + + + type Darray2 is array (Vect4_Pkg.K .. 4) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X : Darray2; Y : Long_Float) return Darray2; + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2); + + + type Darray3 is array (Vect4_Pkg.K .. Vect4_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X : Darray3; Y : Long_Float) return Darray3; + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3); + +end Vect4; diff --git a/gcc/testsuite/gnat.dg/vect4_pkg.ads b/gcc/testsuite/gnat.dg/vect4_pkg.ads new file mode 100644 index 00000000000..2e0008d0a71 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect4_pkg.ads @@ -0,0 +1,6 @@ +package Vect4_Pkg is + + function K return Integer; + function N return Integer; + +end Vect4_Pkg; diff --git a/gcc/testsuite/gnat.dg/vect5.adb b/gcc/testsuite/gnat.dg/vect5.adb new file mode 100644 index 00000000000..98af2c01d54 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect5.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect5 is + + function "+" (X : Varray; Y : Long_Float) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Sarray; Y : Long_Float) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray1; Y : Long_Float) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray2; Y : Long_Float) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray3; Y : Long_Float) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + end; + +end Vect5; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect5.ads b/gcc/testsuite/gnat.dg/vect5.ads new file mode 100644 index 00000000000..09e798aecb2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect5.ads @@ -0,0 +1,42 @@ +with Vect5_Pkg; + +package Vect5 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Positive range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X : Varray; Y : Long_Float) return Varray; + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (Positive (1) .. Positive (4)) of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X : Sarray; Y : Long_Float) return Sarray; + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray); + + + type Darray1 is array (Positive(1) .. Vect5_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X : Darray1; Y : Long_Float) return Darray1; + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1); + + + type Darray2 is array (Vect5_Pkg.K .. Positive(4)) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X : Darray2; Y : Long_Float) return Darray2; + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2); + + + type Darray3 is array (Vect5_Pkg.K .. Vect5_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X : Darray3; Y : Long_Float) return Darray3; + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3); + +end Vect5; diff --git a/gcc/testsuite/gnat.dg/vect5_pkg.ads b/gcc/testsuite/gnat.dg/vect5_pkg.ads new file mode 100644 index 00000000000..9eb752eedb2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect5_pkg.ads @@ -0,0 +1,6 @@ +package Vect5_Pkg is + + function K return Positive; + function N return Positive; + +end Vect5_Pkg; diff --git a/gcc/testsuite/gnat.dg/vect6.adb b/gcc/testsuite/gnat.dg/vect6.adb new file mode 100644 index 00000000000..425f2a70362 --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect6.adb @@ -0,0 +1,93 @@ +-- { dg-do compile { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } + +package body Vect6 is + + function "+" (X : Varray; Y : Long_Float) return Varray is + R : Varray (X'Range); + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is + begin + for I in X'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Sarray; Y : Long_Float) return Sarray is + R : Sarray; + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is + begin + for I in Sarray'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray1; Y : Long_Float) return Darray1 is + R : Darray1; + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is + begin + for I in Darray1'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray2; Y : Long_Float) return Darray2 is + R : Darray2; + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is + begin + for I in Darray2'Range loop + R(I) := X(I) + Y; + end loop; + end; + + + function "+" (X : Darray3; Y : Long_Float) return Darray3 is + R : Darray3; + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + return R; + end; + + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is + begin + for I in Darray3'Range loop + R(I) := X(I) + Y; + end loop; + end; + +end Vect6; + +-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 10 "vect" } } +-- { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/vect6.ads b/gcc/testsuite/gnat.dg/vect6.ads new file mode 100644 index 00000000000..013fe13652e --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect6.ads @@ -0,0 +1,43 @@ +with Vect6_Pkg; + +package Vect6 is + + -- Unconstrained array types are vectorizable, possibly with special + -- help for the programmer + type Varray is array (Vect6_Pkg.Index_Type range <>) of Long_Float; + for Varray'Alignment use 16; + + function "+" (X : Varray; Y : Long_Float) return Varray; + procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray); + + + -- Constrained array types are vectorizable + type Sarray is array (Vect6_Pkg.Index_Type(1) .. Vect6_Pkg.Index_Type(4)) + of Long_Float; + for Sarray'Alignment use 16; + + function "+" (X : Sarray; Y : Long_Float) return Sarray; + procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray); + + + type Darray1 is array (Vect6_Pkg.Index_Type(1) .. Vect6_Pkg.N) of Long_Float; + for Darray1'Alignment use 16; + + function "+" (X : Darray1; Y : Long_Float) return Darray1; + procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1); + + + type Darray2 is array (Vect6_Pkg.K .. Vect6_Pkg.Index_Type(4)) of Long_Float; + for Darray2'Alignment use 16; + + function "+" (X : Darray2; Y : Long_Float) return Darray2; + procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2); + + + type Darray3 is array (Vect6_Pkg.K .. Vect6_Pkg.N) of Long_Float; + for Darray3'Alignment use 16; + + function "+" (X : Darray3; Y : Long_Float) return Darray3; + procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3); + +end Vect6; diff --git a/gcc/testsuite/gnat.dg/vect6_pkg.ads b/gcc/testsuite/gnat.dg/vect6_pkg.ads new file mode 100644 index 00000000000..7db734a359f --- /dev/null +++ b/gcc/testsuite/gnat.dg/vect6_pkg.ads @@ -0,0 +1,10 @@ +with System; + +package Vect6_Pkg is + + type Index_Type is mod System.Memory_Size; + + function K return Index_Type; + function N return Index_Type; + +end Vect6_Pkg; |