FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2014-07-30  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): New predicate.
	(Expand_Array_Aggregate): Also enable in-place expansion for
	code generated by the compiler.  For an object declaration,
	set the kind of the object in addition to its type.  If an
	in-place assignment is to be generated and it can be directly
	done by the back-end, do not expand the aggregate.
	* fe.h (Is_Others_Aggregate): Declare.
	* gcc-interface/trans.c
	(gnat_to_gnu) <N_Assignment_Statement>: Add support for an
	aggregate with a single Others choice on the RHS by means of
	__builtin_memset.  Tidy up.

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* gnat_rm.texi: minor reformatting.

2014-07-30  Yannick Moy  <moy@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Helper_Body): Remove body to inline
	in SPARK_Mode Off.

From-SVN: r213240
This commit is contained in:
Arnaud Charlet 2014-07-30 12:23:17 +02:00
parent eb16ddf8ed
commit ac43e11e23
6 changed files with 276 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
gcc/ada/ChangeLog
View file

@ -1,3 +1,26 @@
2014-07-30 Eric Botcazou <ebotcazou@adacore.com>
* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): New predicate.
(Expand_Array_Aggregate): Also enable in-place expansion for
code generated by the compiler. For an object declaration,
set the kind of the object in addition to its type. If an
in-place assignment is to be generated and it can be directly
done by the back-end, do not expand the aggregate.
* fe.h (Is_Others_Aggregate): Declare.
* gcc-interface/trans.c
(gnat_to_gnu) <N_Assignment_Statement>: Add support for an
aggregate with a single Others choice on the RHS by means of
__builtin_memset. Tidy up.
2014-07-30 Ed Schonberg <schonberg@adacore.com>
* gnat_rm.texi: minor reformatting.
2014-07-30 Yannick Moy <moy@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Helper_Body): Remove body to inline
in SPARK_Mode Off.
2014-07-30 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document additional implementation-defined use

157
gcc/ada/exp_aggr.adb
View file

@ -3945,6 +3945,9 @@ package body Exp_Aggr is
Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
-- The type of each index
In_Place_Assign_OK_For_Declaration : Boolean := False;
-- True if we are to generate an in place assignment for a declaration
Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate
-- is the expression in an assignment, assignment in place may be
@ -3955,6 +3958,9 @@ package body Exp_Aggr is
-- If Others_Present (J) is True, then there is an others choice
-- in one of the sub-aggregates of N at dimension J.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
-- Returns true if an aggregate assignment can be done by the back end
procedure Build_Constrained_Type (Positional : Boolean);
-- If the subtype is not static or unconstrained, build a constrained
-- type using the computable sizes of the aggregate and its sub-
@ -3991,6 +3997,108 @@ package body Exp_Aggr is
-- built directly into the target of the assignment it must be free
-- of side-effects.
------------------------------------
-- Aggr_Assignment_OK_For_Backend --
------------------------------------
-- Backend processing by Gigi/gcc is possible only if all the following
-- conditions are met:
-- 1. N consists of a single OTHERS choice, possibly recursively
-- 2. The component type is discrete
-- 3. The component size is a multiple of Storage_Unit
-- 4. The component size is exactly Storage_Unit or the expression is
-- an integer whose unsigned value is the binary concatenation of
-- K times its remainder modulo 2**Storage_Unit.
-- The ultimate goal is to generate a call to a fast memset routine
-- specifically optimized for the target.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
Ctyp : Entity_Id;
Expr : Node_Id := N;
Remainder : Uint;
Value : Uint;
Nunits : Nat;
begin
-- Recurse as far as possible to find the innermost component type
Ctyp := Etype (N);
while Is_Array_Type (Ctyp) loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
then
return False;
end if;
Expr := Expression (First (Component_Associations (Expr)));
for J in 1 .. Number_Dimensions (Ctyp) - 1 loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
then
return False;
end if;
Expr := Expression (First (Component_Associations (Expr)));
end loop;
Ctyp := Component_Type (Ctyp);
end loop;
if not Is_Discrete_Type (Ctyp)
or else RM_Size (Ctyp) mod System_Storage_Unit /= 0
then
return False;
end if;
-- The expression needs to be analyzed if True is returned
Analyze_And_Resolve (Expr, Ctyp);
Nunits := UI_To_Int (RM_Size (Ctyp) / System_Storage_Unit);
if Nunits = 1 then
return True;
end if;
if not Compile_Time_Known_Value (Expr) then
return False;
end if;
Value := Expr_Value (Expr);
if Has_Biased_Representation (Ctyp) then
Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
end if;
-- 0 and -1 immediately satisfy check #4
if Value = Uint_0 or else Value = Uint_Minus_1 then
return True;
end if;
-- We need to work with an unsigned value
if Value < 0 then
Value := Value + 2**(System_Storage_Unit * Nunits);
end if;
Remainder := Value rem 2**System_Storage_Unit;
for I in 1 .. Nunits - 1 loop
Value := Value / 2**System_Storage_Unit;
if Value rem 2**System_Storage_Unit /= Remainder then
return False;
end if;
end loop;
return True;
end Aggr_Assignment_OK_For_Backend;
----------------------------
-- Build_Constrained_Type --
----------------------------
@ -5065,7 +5173,6 @@ package body Exp_Aggr is
else
Maybe_In_Place_OK :=
(Nkind (Parent (N)) = N_Assignment_Statement
and then Comes_From_Source (N)
and then In_Place_Assign_OK)
or else
@ -5098,22 +5205,27 @@ package body Exp_Aggr is
and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ)
then
In_Place_Assign_OK_For_Declaration := True;
Tmp := Defining_Identifier (Parent (N));
Set_No_Initialization (Parent (N));
Set_Expression (Parent (N), Empty);
-- Set the type of the entity, for use in the analysis of the
-- subsequent indexed assignments. If the nominal type is not
-- Set kind and type of the entity, for use in the analysis
-- of the subsequent assignments. If the nominal type is not
-- constrained, build a subtype from the known bounds of the
-- aggregate. If the declaration has a subtype mark, use it,
-- otherwise use the itype of the aggregate.
Set_Ekind (Tmp, E_Variable);
if not Is_Constrained (Typ) then
Build_Constrained_Type (Positional => False);
elsif Is_Entity_Name (Object_Definition (Parent (N)))
and then Is_Constrained (Entity (Object_Definition (Parent (N))))
then
Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
else
Set_Size_Known_At_Compile_Time (Typ, False);
Set_Etype (Tmp, Typ);
@ -5150,7 +5262,6 @@ package body Exp_Aggr is
elsif Maybe_In_Place_OK
and then Nkind (Name (Parent (N))) = N_Slice
and then Comes_From_Source (N)
and then Is_Others_Aggregate (N)
then
Tmp := Name (Parent (N));
@ -5214,12 +5325,38 @@ package body Exp_Aggr is
Target := New_Copy (Tmp);
end if;
Aggr_Code :=
Build_Array_Aggr_Code (N,
Ctype => Ctyp,
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Ctyp));
-- If we are to generate an in place assignment for a declaration or
-- an assignment statement, and the assignment can be done directly
-- by the back end, then do not expand further.
-- ??? We can also do that if in place expansion is not possible but
-- then we could go into an infinite recursion.
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
and then not AAMP_On_Target
and then VM_Target = No_VM
and then not Generate_SCIL
and then not Possible_Bit_Aligned_Component (Target)
and then Aggr_Assignment_OK_For_Backend (N)
then
if Maybe_In_Place_OK then
return;
end if;
Aggr_Code :=
New_List (
Make_Assignment_Statement (Loc,
Name => Target,
Expression => New_Copy (N)));
else
Aggr_Code :=
Build_Array_Aggr_Code (N,
Ctype => Ctyp,
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Ctyp));
end if;
-- Save the last assignment statement associated with the aggregate
-- when building a controlled object. This reference is utilized by

5
gcc/ada/fe.h
View file

@ -202,6 +202,11 @@ extern void Check_No_Implicit_Heap_Alloc (Node_Id);
extern void Check_Elaboration_Code_Allowed (Node_Id);
extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id);
/* sem_aggr: */
#define Is_Others_Aggregate sem_aggr__is_others_aggregate
extern Boolean Is_Others_Aggregate (Node_Id);
/* sem_aux: */
#define Ancestor_Subtype sem_aux__ancestor_subtype

124
gcc/ada/gcc-interface/trans.c
View file

@ -2400,9 +2400,11 @@ Case_Statement_to_gnu (Node_Id gnat_node)
/* First compile all the different case choices for the current WHEN
alternative. */
for (gnat_choice = First (Discrete_Choices (gnat_when));
Present (gnat_choice); gnat_choice = Next (gnat_choice))
Present (gnat_choice);
gnat_choice = Next (gnat_choice))
{
tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
tree label = create_artificial_label (input_location);
switch (Nkind (gnat_choice))
{
@ -2426,8 +2428,8 @@ Case_Statement_to_gnu (Node_Id gnat_node)
{
tree gnu_type = get_unpadded_type (Entity (gnat_choice));
gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
gnu_low = TYPE_MIN_VALUE (gnu_type);
gnu_high = TYPE_MAX_VALUE (gnu_type);
break;
}
@ -2445,20 +2447,13 @@ Case_Statement_to_gnu (Node_Id gnat_node)
gcc_unreachable ();
}
/* If the case value is a subtype that raises Constraint_Error at
run time because of a wrong bound, then gnu_low or gnu_high is
not translated into an INTEGER_CST. In such a case, we need
to ensure that the when statement is not added in the tree,
otherwise it will crash the gimplifier. */
if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
&& (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
{
add_stmt_with_node (build_case_label
(gnu_low, gnu_high,
create_artificial_label (input_location)),
gnat_choice);
choices_added_p = true;
}
/* Everything should be folded into constants at this point. */
gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
gnat_choice);
choices_added_p = true;
}
/* This construct doesn't define a scope so we shouldn't push a binding
@ -5713,16 +5708,27 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = alloc_stmt_list ();
break;
case N_Exception_Renaming_Declaration:
gnat_temp = Defining_Entity (gnat_node);
if (Renamed_Entity (gnat_temp) != Empty)
gnu_result
= gnat_to_gnu_entity (gnat_temp,
gnat_to_gnu (Renamed_Entity (gnat_temp)), 1);
else
gnu_result = alloc_stmt_list ();
break;
case N_Implicit_Label_Declaration:
gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
gnu_result = alloc_stmt_list ();
break;
case N_Exception_Renaming_Declaration:
case N_Number_Declaration:
case N_Package_Renaming_Declaration:
case N_Subprogram_Renaming_Declaration:
case N_Package_Renaming_Declaration:
/* These are fully handled in the front end. */
/* ??? For package renamings, find a way to use GENERIC namespaces so
that we get proper debug information for them. */
gnu_result = alloc_stmt_list ();
break;
@ -6479,40 +6485,79 @@ gnat_to_gnu (Node_Id gnat_node)
atomic_sync_required_p (Name (gnat_node)));
else
{
gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
const Node_Id gnat_expr = Expression (gnat_node);
const Entity_Id gnat_type
= Underlying_Type (Etype (Name (gnat_node)));
const bool regular_array_type_p
= (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
const bool use_memset_p
= (regular_array_type_p
&& Nkind (gnat_expr) == N_Aggregate
&& Is_Others_Aggregate (gnat_expr));
/* If we'll use memset, we need to find the inner expression. */
if (use_memset_p)
{
Node_Id gnat_inner
= Expression (First (Component_Associations (gnat_expr)));
while (Nkind (gnat_inner) == N_Aggregate
&& Is_Others_Aggregate (gnat_inner))
gnat_inner
= Expression (First (Component_Associations (gnat_inner)));
gnu_rhs = gnat_to_gnu (gnat_inner);
}
else
gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
/* If range check is needed, emit code to generate it. */
if (Do_Range_Check (Expression (gnat_node)))
if (Do_Range_Check (gnat_expr))
gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
gnat_node);
/* If atomic synchronization is required, build an atomic store. */
if (atomic_sync_required_p (Name (gnat_node)))
gnu_result = build_atomic_store (gnu_lhs, gnu_rhs);
/* Or else, use memset when the conditions are met. */
else if (use_memset_p)
{
tree value = fold_convert (integer_type_node, gnu_rhs);
tree to = gnu_lhs;
tree type = TREE_TYPE (to);
tree size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to);
tree to_ptr = build_fold_addr_expr (to);
tree t = builtin_decl_implicit (BUILT_IN_MEMSET);
if (TREE_CODE (value) == INTEGER_CST)
{
tree mask
= build_int_cst (integer_type_node,
((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
value = int_const_binop (BIT_AND_EXPR, value, mask);
}
gnu_result = build_call_expr (t, 3, to_ptr, value, size);
}
/* Otherwise build a regular assignment. */
else
gnu_result
= build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
/* If the type being assigned is an array type and the two sides are
/* If the assignment type is a regular array and the two sides are
not completely disjoint, play safe and use memmove. But don't do
it for a bit-packed array as it might not be byte-aligned. */
if (TREE_CODE (gnu_result) == MODIFY_EXPR
&& Is_Array_Type (Etype (Name (gnat_node)))
&& !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
&& regular_array_type_p
&& !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
{
tree to, from, size, to_ptr, from_ptr, t;
to = TREE_OPERAND (gnu_result, 0);
from = TREE_OPERAND (gnu_result, 1);
size = TYPE_SIZE_UNIT (TREE_TYPE (from));
size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
to_ptr = build_fold_addr_expr (to);
from_ptr = build_fold_addr_expr (from);
t = builtin_decl_implicit (BUILT_IN_MEMMOVE);
tree to = TREE_OPERAND (gnu_result, 0);
tree from = TREE_OPERAND (gnu_result, 1);
tree type = TREE_TYPE (from);
tree size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
tree to_ptr = build_fold_addr_expr (to);
tree from_ptr = build_fold_addr_expr (from);
tree t = builtin_decl_implicit (BUILT_IN_MEMMOVE);
gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
}
}
@ -7457,7 +7502,10 @@ add_stmt_force (tree gnu_stmt)
void
add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
{
if (Present (gnat_node))
/* Do not emit a location for renamings that come from generic instantiation,
they are likely to disturb debugging. */
if (Present (gnat_node)
&& !renaming_from_generic_instantiation_p (gnat_node))
set_expr_location_from_node (gnu_stmt, gnat_node);
add_stmt (gnu_stmt);
}

6
gcc/ada/gnat_rm.texi
View file

@ -8821,9 +8821,9 @@ In addition to the usage of this attribute in the Ada RM, @code{GNAT}
also permits the use of the @code{'Constrained} attribute
in a generic template
for any type, including types without discriminants. The value of this
attribute in the generic instance when applied to a type without
discriminants is always @code{True}. This usage is compatible with
older Ada compilers, including notably DEC Ada.
attribute in the generic instance when applied to a scalar type or a
record type without discriminants is always @code{True}. This usage is
compatible with older Ada compilers, including notably DEC Ada.
@node Attribute Default_Bit_Order
@unnumberedsec Attribute Default_Bit_Order

12
gcc/ada/sem_ch6.adb
View file

@ -3527,6 +3527,18 @@ package body Sem_Ch6 is
end if;
end if;
-- If SPARK_Mode for body is not On, disable frontend inlining for this
-- subprogram in GNATprove mode, as its body should not be analyzed.
if SPARK_Mode /= On
and then GNATprove_Mode
and then Debug_Flag_QQ
and then Present (Spec_Id)
and then Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Declaration
then
Set_Body_To_Inline (Parent (Parent (Spec_Id)), Empty);
end if;
-- Check completion, and analyze the statements
Check_Completion;