Commit 094cefda by Arnaud Charlet

[multiple changes]

2010-10-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): If the expression in an
	others choice is a literal analyze it now to enable later optimizations.
	* exp_aggr.adb (Expand_Record_Aggregate): An aggregate with static size
	and components can be handled by the backend even if it is of a limited
	type.

2010-10-08  Arnaud Charlet  <charlet@adacore.com>

	* a-rttiev.adb (task Timer): Since this package may be elaborated
	before System.Interrupt, we need to call Setup_Interrupt_Mask
	explicitly to ensure that this task has the proper signal mask.

2010-10-08  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Freeze_Entity): For array case, move some processing for
	pragma Pack, Component_Size clause and atomic/volatile components here
	instead of trying to do the job in Sem_Ch13 and Freeze.
	* layout.adb: Use new Addressable function
	* sem_ch13.adb (Analyze_Attribute_Representation_Clause, case
	Component_Size): Move some handling to freeze point in
	Freeze.Freeze_Entity.
	* sem_prag.adb (Analyze_pragma, case Pack): Move some handling to
	freeze point in Freese.Freeze_Entity.
	* sem_util.ads, sem_util.adb (Addressable): New function.

From-SVN: r165159
parent 0ac2a660
2010-10-08 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): If the expression in an
others choice is a literal analyze it now to enable later optimizations.
* exp_aggr.adb (Expand_Record_Aggregate): An aggregate with static size
and components can be handled by the backend even if it is of a limited
type.
2010-10-08 Arnaud Charlet <charlet@adacore.com>
* a-rttiev.adb (task Timer): Since this package may be elaborated
before System.Interrupt, we need to call Setup_Interrupt_Mask
explicitly to ensure that this task has the proper signal mask.
2010-10-08 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Entity): For array case, move some processing for
pragma Pack, Component_Size clause and atomic/volatile components here
instead of trying to do the job in Sem_Ch13 and Freeze.
* layout.adb: Use new Addressable function
* sem_ch13.adb (Analyze_Attribute_Representation_Clause, case
Component_Size): Move some handling to freeze point in
Freeze.Freeze_Entity.
* sem_prag.adb (Analyze_pragma, case Pack): Move some handling to
freeze point in Freese.Freeze_Entity.
* sem_util.ads, sem_util.adb (Addressable): New function.
2010-10-08 Robert Dewar <dewar@adacore.com> 2010-10-08 Robert Dewar <dewar@adacore.com>
* sprint.adb: Minor reformatting. * sprint.adb: Minor reformatting.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,6 +32,7 @@ ...@@ -32,6 +32,7 @@
with System.Task_Primitives.Operations; with System.Task_Primitives.Operations;
with System.Tasking.Utilities; with System.Tasking.Utilities;
with System.Soft_Links; with System.Soft_Links;
with System.Interrupt_Management.Operations;
with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Doubly_Linked_Lists;
pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
...@@ -98,6 +99,12 @@ package body Ada.Real_Time.Timing_Events is ...@@ -98,6 +99,12 @@ package body Ada.Real_Time.Timing_Events is
begin begin
System.Tasking.Utilities.Make_Independent; System.Tasking.Utilities.Make_Independent;
-- Since this package may be elaborated before System.Interrupt,
-- we need to call Setup_Interrupt_Mask explicitly to ensure that
-- this task has the proper signal mask.
System.Interrupt_Management.Operations.Setup_Interrupt_Mask;
-- We await the call to Start to ensure that Event_Queue_Lock has been -- We await the call to Start to ensure that Event_Queue_Lock has been
-- initialized by the package executable part prior to accessing it in -- initialized by the package executable part prior to accessing it in
-- the loop. The task is activated before the first statement of the -- the loop. The task is activated before the first statement of the
......
...@@ -3773,6 +3773,13 @@ package body Exp_Aggr is ...@@ -3773,6 +3773,13 @@ package body Exp_Aggr is
then then
null; null;
elsif Is_Entity_Name (Expression (Expr))
and then Present (Entity (Expression (Expr)))
and then Ekind (Entity (Expression (Expr))) =
E_Enumeration_Literal
then
null;
elsif Nkind (Expression (Expr)) /= N_Aggregate elsif Nkind (Expression (Expr)) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expression (Expr)) or else not Compile_Time_Known_Aggregate (Expression (Expr))
or else Expansion_Delayed (Expression (Expr)) or else Expansion_Delayed (Expression (Expr))
...@@ -5491,6 +5498,14 @@ package body Exp_Aggr is ...@@ -5491,6 +5498,14 @@ package body Exp_Aggr is
C := First (Comps); C := First (Comps);
while Present (C) loop while Present (C) loop
-- If the component has box initialization, expansion is needed
-- and component is not ready for backend.
if Box_Present (C) then
return True;
end if;
if Nkind (Expression (C)) = N_Qualified_Expression then if Nkind (Expression (C)) = N_Qualified_Expression then
Expr_Q := Expression (Expression (C)); Expr_Q := Expression (Expression (C));
else else
...@@ -5576,14 +5591,33 @@ package body Exp_Aggr is ...@@ -5576,14 +5591,33 @@ package body Exp_Aggr is
end if; end if;
-- Ada 2005 (AI-318-2): We need to convert to assignments if components -- Ada 2005 (AI-318-2): We need to convert to assignments if components
-- are build-in-place function calls. This test could be more specific, -- are build-in-place function calls. The assignments will each turn
-- but doing it for all inherently limited aggregates seems harmless. -- into a build-in-place function call. If components are all static,
-- The assignments will turn into build-in-place function calls (see -- we can pass the aggregate to the backend regardless of limitedness.
-- Make_Build_In_Place_Call_In_Assignment).
-- Extension aggregates, aggregates in extended return statements, and
-- aggregates for C++ imported types must be expanded.
if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
if Nkind (Parent (N)) /= N_Object_Declaration then
Convert_To_Assignments (N, Typ); Convert_To_Assignments (N, Typ);
elsif Nkind (N) = N_Extension_Aggregate
or else Convention (Typ) = Convention_CPP
then
Convert_To_Assignments (N, Typ);
elsif not Size_Known_At_Compile_Time (Typ)
or else Component_Not_OK_For_Backend
or else not Static_Components
then
Convert_To_Assignments (N, Typ);
else
Set_Compile_Time_Known_Aggregate (N);
Set_Expansion_Delayed (N, False);
end if;
-- Gigi doesn't handle properly temporaries of variable size -- Gigi doesn't handle properly temporaries of variable size
-- so we generate it in the front-end -- so we generate it in the front-end
......
...@@ -3097,7 +3097,9 @@ package body Freeze is ...@@ -3097,7 +3097,9 @@ package body Freeze is
if Is_Array_Type (E) then if Is_Array_Type (E) then
declare declare
FS : constant Entity_Id := First_Subtype (E);
Ctyp : constant Entity_Id := Component_Type (E); Ctyp : constant Entity_Id := Component_Type (E);
Clause : Entity_Id;
Non_Standard_Enum : Boolean := False; Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type -- Set true if any of the index types is an enumeration type
...@@ -3150,8 +3152,8 @@ package body Freeze is ...@@ -3150,8 +3152,8 @@ package body Freeze is
begin begin
if (Is_Packed (E) or else Has_Pragma_Pack (E)) if (Is_Packed (E) or else Has_Pragma_Pack (E))
and then not Has_Atomic_Components (E)
and then Known_Static_RM_Size (Ctyp) and then Known_Static_RM_Size (Ctyp)
and then not Has_Component_Size_Clause (E)
then then
Csiz := UI_Max (RM_Size (Ctyp), 1); Csiz := UI_Max (RM_Size (Ctyp), 1);
...@@ -3213,6 +3215,7 @@ package body Freeze is ...@@ -3213,6 +3215,7 @@ package body Freeze is
if Present (Comp_Size_C) if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent) and then Has_Pragma_Pack (Ent)
and then Warn_On_Redundant_Constructs
then then
Error_Msg_Sloc := Sloc (Comp_Size_C); Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE Error_Msg_NE
...@@ -3221,6 +3224,8 @@ package body Freeze is ...@@ -3221,6 +3224,8 @@ package body Freeze is
Error_Msg_N Error_Msg_N
("\?explicit component size given#!", ("\?explicit component size given#!",
Pack_Pragma); Pack_Pragma);
Set_Is_Packed (Base_Type (Ent), False);
Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
end if; end if;
-- Set component size if not already set by a -- Set component size if not already set by a
...@@ -3278,18 +3283,128 @@ package body Freeze is ...@@ -3278,18 +3283,128 @@ package body Freeze is
-- request may be ignored. -- request may be ignored.
Set_Is_Packed (Base_Type (E), False); Set_Is_Packed (Base_Type (E), False);
Set_Is_Bit_Packed_Array (Base_Type (E), False);
if Known_Static_Esize (Component_Type (E))
and then Esize (Component_Type (E)) = Csiz
then
Set_Has_Non_Standard_Rep
(Base_Type (E), False);
end if;
-- In all other cases, packing is indeed needed -- In all other cases, packing is indeed needed
else else
Set_Has_Non_Standard_Rep (Base_Type (E)); Set_Has_Non_Standard_Rep (Base_Type (E), True);
Set_Is_Bit_Packed_Array (Base_Type (E)); Set_Is_Bit_Packed_Array (Base_Type (E), True);
Set_Is_Packed (Base_Type (E)); Set_Is_Packed (Base_Type (E), True);
end if; end if;
end; end;
end if; end if;
end; end;
-- Check for Atomic_Components or Aliased with unsuitable
-- packing or explicit component size clause given.
if (Has_Atomic_Components (E)
or else Has_Aliased_Components (E))
and then (Has_Component_Size_Clause (E)
or else Is_Packed (E))
then
Alias_Atomic_Check : declare
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or
-- pragma Pack for aliased or atomic components (T is
-- "aliased" or "atomic");
-----------------
-- Complain_CS --
-----------------
procedure Complain_CS (T : String) is
begin
if Has_Component_Size_Clause (E) then
Clause :=
Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size);
if Known_Static_Esize (Ctyp) then
Error_Msg_N
("incorrect component size for "
& T & " components", Clause);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N
("\only allowed value is^", Clause);
else
Error_Msg_N
("component size cannot be given for "
& T & " components", Clause);
end if;
else
Error_Msg_N
("cannot pack " & T & " components",
Get_Rep_Pragma (FS, Name_Pack));
end if;
return;
end Complain_CS;
-- Start of processing for Alias_Atomic_Check
begin
-- Case where component size has no effect
if Known_Static_Esize (Ctyp)
and then Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp)
and then Esize (Ctyp) mod 8 = 0
then
null;
elsif Has_Aliased_Components (E)
or else Is_Aliased (Ctyp)
then
Complain_CS ("aliased");
elsif Has_Atomic_Components (E)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
end if;
end Alias_Atomic_Check;
end if;
-- Warn for case of atomic type
Clause := Get_Rep_Pragma (FS, Name_Atomic);
if Present (Clause)
and then not Addressable (Component_Size (FS))
then
Error_Msg_NE
("non-atomic components of type& may not be "
& "accessible by separate tasks?", Clause, E);
if Has_Component_Size_Clause (E) then
Error_Msg_Sloc :=
Sloc
(Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size));
Error_Msg_N
("\because of component size clause#?",
Clause);
elsif Has_Pragma_Pack (E) then
Error_Msg_Sloc :=
Sloc (Get_Rep_Pragma (FS, Name_Pack));
Error_Msg_N
("\because of pragma Pack#?", Clause);
end if;
end if;
-- Processing that is done only for subtypes -- Processing that is done only for subtypes
else else
...@@ -4749,11 +4864,7 @@ package body Freeze is ...@@ -4749,11 +4864,7 @@ package body Freeze is
-- natural boundary of size. -- natural boundary of size.
elsif Size_Incl_EP /= Size_Excl_EP elsif Size_Incl_EP /= Size_Excl_EP
and then and then Addressable (Size_Excl_EP)
(Size_Excl_EP = 8 or else
Size_Excl_EP = 16 or else
Size_Excl_EP = 32 or else
Size_Excl_EP = 64)
then then
Actual_Size := Size_Excl_EP; Actual_Size := Size_Excl_EP;
Actual_Lo := Loval_Excl_EP; Actual_Lo := Loval_Excl_EP;
......
...@@ -2568,14 +2568,9 @@ package body Layout is ...@@ -2568,14 +2568,9 @@ package body Layout is
then then
declare declare
S : constant Uint := Esize (CT); S : constant Uint := Esize (CT);
begin begin
if S = 8 or else if Addressable (S) then
S = 16 or else Set_Component_Size (E, S);
S = 32 or else
S = 64
then
Set_Component_Size (E, Esize (CT));
end if; end if;
end; end;
end if; end if;
......
...@@ -1795,6 +1795,19 @@ package body Sem_Aggr is ...@@ -1795,6 +1795,19 @@ package body Sem_Aggr is
Expander_Mode_Save_And_Set (False); Expander_Mode_Save_And_Set (False);
Full_Analysis := False; Full_Analysis := False;
Analyze (Expr); Analyze (Expr);
-- If the expression is a literal, propagate this info
-- to the expression in the association, to enable some
-- optimizations downstream.
if Is_Entity_Name (Expr)
and then Present (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Enumeration_Literal
then
Analyze_And_Resolve
(Expression (Assoc), Component_Typ);
end if;
Full_Analysis := Save_Analysis; Full_Analysis := Save_Analysis;
Expander_Mode_Restore; Expander_Mode_Restore;
......
...@@ -1298,34 +1298,6 @@ package body Sem_Ch13 is ...@@ -1298,34 +1298,6 @@ package body Sem_Ch13 is
Biased : Boolean; Biased : Boolean;
New_Ctyp : Entity_Id; New_Ctyp : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
Ignore : Boolean := False;
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause for aliased or
-- atomic components (T is "aliased" or "atomic");
-----------------
-- Complain_CS --
-----------------
procedure Complain_CS (T : String) is
begin
if Known_Static_Esize (Ctyp) then
Error_Msg_N
("incorrect component size for " & T & " components", N);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N ("\only allowed value is^", N);
else
Error_Msg_N
("component size cannot be given for " & T & " components",
N);
end if;
return;
end Complain_CS;
-- Start of processing for Component_Size_Case
begin begin
if not Is_Array_Type (U_Ent) then if not Is_Array_Type (U_Ent) then
...@@ -1340,41 +1312,12 @@ package body Sem_Ch13 is ...@@ -1340,41 +1312,12 @@ package body Sem_Ch13 is
Error_Msg_N Error_Msg_N
("component size clause for& previously given", Nam); ("component size clause for& previously given", Nam);
elsif Rep_Item_Too_Early (Btype, N) then
null;
elsif Csize /= No_Uint then elsif Csize /= No_Uint then
Check_Size (Expr, Ctyp, Csize, Biased); Check_Size (Expr, Ctyp, Csize, Biased);
-- Case where component size has no effect
if Known_Static_Esize (Ctyp)
and then Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp)
and then (Esize (Ctyp) = 8 or else
Esize (Ctyp) = 16 or else
Esize (Ctyp) = 32 or else
Esize (Ctyp) = 64)
then
Ignore := True;
-- Cannot give component size for aliased/atomic components
elsif Has_Aliased_Components (Btype)
or else Is_Aliased (Ctyp)
then
Complain_CS ("aliased");
elsif Has_Atomic_Components (Btype)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
-- Warn for case of atomic type
elsif Is_Atomic (Btype) then
Error_Msg_NE
("non-atomic components of type& may not be accessible "
& "by separate tasks?", N, Btype);
end if;
-- For the biased case, build a declaration for a subtype -- For the biased case, build a declaration for a subtype
-- that will be used to represent the biased subtype that -- that will be used to represent the biased subtype that
-- reflects the biased representation of components. We need -- reflects the biased representation of components. We need
...@@ -1435,11 +1378,8 @@ package body Sem_Ch13 is ...@@ -1435,11 +1378,8 @@ package body Sem_Ch13 is
end if; end if;
Set_Has_Component_Size_Clause (Btype, True); Set_Has_Component_Size_Clause (Btype, True);
if not Ignore then
Set_Has_Non_Standard_Rep (Btype, True); Set_Has_Non_Standard_Rep (Btype, True);
end if; end if;
end if;
end Component_Size_Case; end Component_Size_Case;
------------------ ------------------
......
...@@ -5928,7 +5928,6 @@ package body Sem_Prag is ...@@ -5928,7 +5928,6 @@ package body Sem_Prag is
E : Entity_Id; E : Entity_Id;
D : Node_Id; D : Node_Id;
K : Node_Kind; K : Node_Kind;
Ctyp : Entity_Id;
begin begin
Check_Ada_83_Warning; Check_Ada_83_Warning;
...@@ -5970,24 +5969,6 @@ package body Sem_Prag is ...@@ -5970,24 +5969,6 @@ package body Sem_Prag is
if Prag_Id = Pragma_Atomic_Components then if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E); Set_Has_Atomic_Components (E);
if Is_Packed (E) then
Set_Is_Packed (E, False);
if Is_Array_Type (E) then
Ctyp := Component_Type (E);
else
Ctyp := Component_Type (Etype (E));
end if;
if not (Known_Static_Esize (Ctyp)
and then Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp))
then
Error_Pragma_Arg
("cannot pack atomic components", Arg1);
end if;
end if;
end if; end if;
else else
...@@ -8091,9 +8072,9 @@ package body Sem_Prag is ...@@ -8091,9 +8072,9 @@ package body Sem_Prag is
Record_Rep_Item (Proc_Id, N); Record_Rep_Item (Proc_Id, N);
end Implemented; end Implemented;
----------------------- ----------------------
-- Implicit_Packing -- -- Implicit_Packing --
----------------------- ----------------------
-- pragma Implicit_Packing; -- pragma Implicit_Packing;
...@@ -9991,50 +9972,15 @@ package body Sem_Prag is ...@@ -9991,50 +9972,15 @@ package body Sem_Prag is
if Known_Static_Esize (Ctyp) if Known_Static_Esize (Ctyp)
and then Known_Static_RM_Size (Ctyp) and then Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp) and then Esize (Ctyp) = RM_Size (Ctyp)
and then (Esize (Ctyp) = 8 or else and then Addressable (Esize (Ctyp))
Esize (Ctyp) = 16 or else
Esize (Ctyp) = 32 or else
Esize (Ctyp) = 64)
then then
Ignore := True; Ignore := True;
-- Pack not allowed for aliased/atomic components
elsif Has_Aliased_Components (Base_Type (Typ)) then
Error_Pragma ("cannot pack aliased components");
elsif Has_Atomic_Components (Typ)
or else Is_Atomic (Component_Type (Typ))
then
Error_Pragma ("cannot pack atomic components");
-- Warn for cases of packing non-atomic components of atomic
elsif Is_Atomic (Typ) then
Error_Msg_NE
("non-atomic components of type& may not be accessible "
& "by separate tasks?", N, Typ);
end if;
-- If we had an explicit component size given, then we do not
-- let Pack override this given size. We also give a warning
-- that Pack is being ignored unless we can tell for sure that
-- the Pack would not have had any effect anyway.
if Has_Component_Size_Clause (Typ) then
if Known_Static_RM_Size (Component_Type (Typ))
and then
RM_Size (Component_Type (Typ)) = Component_Size (Typ)
then
null;
else
Error_Pragma
("?pragma% ignored, explicit component size given");
end if; end if;
-- If no prior array component size given, Pack is effective -- Process OK pragma Pack. Note that if there is a separate
-- component clause present, the Pack will be cancelled. This
-- processing is in Freeze.
else
if not Rep_Item_Too_Late (Typ, N) then if not Rep_Item_Too_Late (Typ, N) then
-- In the context of static code analysis, we do not need -- In the context of static code analysis, we do not need
...@@ -10062,7 +10008,6 @@ package body Sem_Prag is ...@@ -10062,7 +10008,6 @@ package body Sem_Prag is
("?pragma% ignored in this configuration"); ("?pragma% ignored in this configuration");
end if; end if;
end if; end if;
end if;
-- For record types, the pack is always effective -- For record types, the pack is always effective
......
...@@ -245,6 +245,28 @@ package body Sem_Util is ...@@ -245,6 +245,28 @@ package body Sem_Util is
Analyze (N); Analyze (N);
end Add_Global_Declaration; end Add_Global_Declaration;
-----------------
-- Addressable --
-----------------
-- For now, just 8/16/32/64. but analyze later if AAMP is special???
function Addressable (V : Uint) return Boolean is
begin
return V = Uint_8 or else
V = Uint_16 or else
V = Uint_32 or else
V = Uint_64;
end Addressable;
function Addressable (V : Int) return Boolean is
begin
return V = 8 or else
V = 16 or else
V = 32 or else
V = 64;
end Addressable;
----------------------- -----------------------
-- Alignment_In_Bits -- -- Alignment_In_Bits --
----------------------- -----------------------
......
...@@ -51,6 +51,12 @@ package Sem_Util is ...@@ -51,6 +51,12 @@ package Sem_Util is
-- for the current unit. The declarations are added in the current scope, -- for the current unit. The declarations are added in the current scope,
-- so the caller should push a new scope as required before the call. -- so the caller should push a new scope as required before the call.
function Addressable (V : Uint) return Boolean;
function Addressable (V : Int) return Boolean;
pragma Inline (Addressable);
-- Returns True if the value of V is the word size of an addressable
-- factor of the word size (typically 8, 16, 32 or 64).
function Alignment_In_Bits (E : Entity_Id) return Uint; function Alignment_In_Bits (E : Entity_Id) return Uint;
-- If the alignment of the type or object E is currently known to the -- If the alignment of the type or object E is currently known to the
-- compiler, then this function returns the alignment value in bits. -- compiler, then this function returns the alignment value in bits.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment