This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Enable vectorization for loops with dynamic bounds
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Wed, 12 Oct 2011 23:56:56 +0200
- Subject: [Ada] Enable vectorization for loops with dynamic bounds
Loops with static bounds are reasonably well vectorized in Ada. Problems arise
when things start to go dynamic, because of the dynamic bounds themselves but
also because of the checks. This patch is a first step towards enabling more
vectorization in the dynamic cases. The generated code isn't pretty though...
Tested on i586-suse-linux, applied on the mainline.
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-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.
--
Eric Botcazou
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 179844)
+++ gcc-interface/utils.c (working copy)
@@ -1771,7 +1771,7 @@ process_attributes (tree decl, struct at
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
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 179844)
+++ gcc-interface/decl.c (working copy)
@@ -1431,10 +1431,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
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 ())
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 179844)
+++ gcc-interface/utils2.c (working copy)
@@ -798,7 +798,7 @@ build_binary_op (enum tree_code op_code,
/* 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
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;
+}
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 179844)
+++ gcc-interface/gigi.h (working copy)
@@ -492,6 +492,10 @@ extern bool fntype_same_flags_p (const_t
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);
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 179844)
+++ gcc-interface/trans.c (working copy)
@@ -189,8 +189,33 @@ static GTY(()) VEC(tree,gc) *gnu_return_
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, tr
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, tr
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);
- default:
- break;
+ /* 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;
}
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);
Index: gcc-interface/ada-tree.h
===================================================================
--- gcc-interface/ada-tree.h (revision 179844)
+++ gcc-interface/ada-tree.h (working copy)
@@ -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) \
Index: gcc-interface/misc.c
===================================================================
--- gcc-interface/misc.c (revision 179844)
+++ gcc-interface/misc.c (working copy)
@@ -394,8 +394,12 @@ gnat_print_decl (FILE *file, tree node,
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:
-- { 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" } }
package Vect1_Pkg is
function K return Integer;
function N return Integer;
end Vect1_Pkg;
-- { 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" } }
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;
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;
-- { 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" } }
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;
package Vect2_Pkg is
function K return Positive;
function N return Positive;
end Vect2_Pkg;
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;
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;
-- { 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" } }
package Vect4_Pkg is
function K return Integer;
function N return Integer;
end Vect4_Pkg;
-- { 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" } }
package Vect5_Pkg is
function K return Positive;
function N return Positive;
end Vect5_Pkg;
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;
-- { 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" } }
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;
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;