diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-03-26 07:39:17 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-03-26 07:39:17 +0000 |
| commit | acf97c1176abc4bfda6f960b4de65efa8492354e (patch) | |
| tree | 535fe9f7a2bfeba1b8bafd9aa970c714dda36fad /gcc | |
| parent | f3635788b320af298216c1ff9cc02a7924b24e0e (diff) | |
| download | gcc-acf97c1176abc4bfda6f960b4de65efa8492354e.tar.gz | |
2008-03-26 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute
Is_Static_Dispatch_Table
(Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls
to Exchange_Declarations to exchange the private and full-view. Bug
found working in this issue.
(Expand_Dispatching_Call): Propagate the convention of the subprogram
to the subprogram pointer type.
(Make_Secondary_DT): Replace generation of Prim'Address by
Address (Prim'Unrestricted_Access)
(Make_DT): Replace generation of Prim'Address by
Address (Prim'Unrestricted_Access)
(Make_Disp_*_Bodies): When compiling for a restricted profile, use
simple call form for single entry.
(Make_DT): Handle new contents of Access_Disp_Table (access to dispatch
tables of predefined primitives).
(Make_Secondary_DT): Add support to handle access to dispatch tables of
predefined primitives.
(Make_Tags): Add entities to Access_Dispatch_Table associated with
access to dispatch tables containing predefined primitives.
* exp_ch6.adb (N_Pragma): Chars field removed, use Chars
(Pragma_Identifier (.. instead, adjustments throughout to accomodate
this change.
(Register_Predefined_DT_Entry): Updated to handle the new contents
of attribute Access_Disp_Table (pointers to dispatch tables containing
predefined primitives).
* exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New
subprogram.
(Find_Interface_ADT): Updated to skip the new contents of attribute
Access_Dispatch_Table (pointers to dispatch tables containing predefined
primitives).
* sem_util.adb (Has_Abstract_Interfaces): Add missing support for
concurrent types.
(Set_Convention): Use new function Is_Access_Subprogram_Type
(Collect_Interfaces_Info): Updated to skip the new contents of attribute
Access_Dispatch_Table (pointers to dispatch tables containing predefined
primitives).
* exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve
expanded code avoiding calls to Build_Predef_Prims.
(Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding
call to Build_Get_Predefined_Prim_Op_Address.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133564 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/exp_atag.adb | 93 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 883 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 52 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 141 |
7 files changed, 849 insertions, 424 deletions
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 670ddf8b868..c2c37a7eb30 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -369,64 +369,32 @@ package body Exp_Atag is New_Tag_Node : Node_Id) return Node_Id is begin - if RTE_Available (RE_DT) then - return - Make_Assignment_Statement (Loc, - Name => - Make_Slice (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), - Make_Selected_Component (Loc, - Prefix => - Build_DT (Loc, New_Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Predef_Prims), Loc)))), - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), - - Expression => - Make_Slice (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), - Make_Selected_Component (Loc, - Prefix => - Build_DT (Loc, Old_Tag_Node), - Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Predef_Prims), Loc)))), - - Discrete_Range => - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => - New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); - else - return - Make_Assignment_Statement (Loc, - Name => - Make_Slice (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Build_Predef_Prims (Loc, New_Tag_Node)), - Discrete_Range => Make_Range (Loc, - Make_Integer_Literal (Loc, Uint_1), - New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), + return + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + New_Tag_Node)))), + Discrete_Range => Make_Range (Loc, + Make_Integer_Literal (Loc, Uint_1), + New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), - Expression => - Make_Slice (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Build_Predef_Prims (Loc, Old_Tag_Node)), - Discrete_Range => - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => - New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); - end if; + Expression => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Old_Tag_Node)))), + Discrete_Range => + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); end Build_Inherit_Predefined_Prims; ------------------------ @@ -472,8 +440,15 @@ package body Exp_Atag is begin return Make_Assignment_Statement (Loc, - Name => Build_Get_Predefined_Prim_Op_Address (Loc, - Tag_Node, Position), + Name => + Make_Indexed_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), + Expressions => + New_List (Make_Integer_Literal (Loc, Position))), + Expression => Address_Node); end Build_Set_Predefined_Prim_Op_Address; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 5f22431062b..9d724f29140 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -90,15 +90,16 @@ package Exp_Atag is -- Generates: TSD (Tag).Transportable; function Build_Inherit_Predefined_Prims - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id) return Node_Id; -- Build code that inherits the predefined primitives of the parent. -- -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Predefined_DT (Old_T).D (All_Predefined_Prims); -- - -- Required to build the dispatch tables with the 3.4 backend. + -- Required to build non-library level dispatch tables. Also required + -- when compiling without static dispatch tables support. function Build_Inherit_Prims (Loc : Source_Ptr; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8d75049fbc7..c5f88c7a898 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3388,7 +3388,7 @@ package body Exp_Ch6 is -- not be posting warnings on the inlined body so it is unneeded. elsif Nkind (N) = N_Pragma - and then Chars (N) = Name_Unreferenced + and then Pragma_Name (N) = Name_Unreferenced then Rewrite (N, Make_Null_Statement (Sloc (N))); return OK; @@ -4756,14 +4756,14 @@ package body Exp_Ch6 is return; end if; - -- Skip the first access-to-dispatch-table pointer since it leads - -- to the primary dispatch table. We are only concerned with the - -- secondary dispatch table pointers. Note that the access-to- - -- dispatch-table pointer corresponds to the first implemented - -- interface retrieved below. + -- Skip the first two access-to-dispatch-table pointers since they + -- leads to the primary dispatch table (predefined DT and user + -- defined DT). We are only concerned with the secondary dispatch + -- table pointers. Note that the access-to- dispatch-table pointer + -- corresponds to the first implemented interface retrieved below. Iface_DT_Ptr := - Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))); + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant @@ -4776,23 +4776,41 @@ package body Exp_Ch6 is Thunk_Code, Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc), + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), Position => DT_Position (Prim), Address_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address)), + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access))), Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To - (Node (Next_Elmt (Iface_DT_Ptr)), Loc), + Tag_Node => + New_Reference_To + (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), + Loc), Position => DT_Position (Prim), Address_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address)))); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access))))); end if; + -- Skip the tag of the predefined primitives dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the no-thunks dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the predefined primitives no-thunks dispatch + -- table + Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index de26ec249fa..c14c7348dea 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -46,6 +46,7 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; @@ -175,14 +176,14 @@ package body Exp_Disp is /= E_Record_Subtype then declare - E1, E2 : Entity_Id; + E1 : constant Entity_Id := Defining_Entity (D); + E2 : constant Entity_Id := Full_View (Defining_Entity (D)); + begin - E1 := Defining_Entity (D); - E2 := Full_View (Defining_Entity (D)); - Exchange_Entities (E1, E2); + Exchange_Declarations (E1); Insert_List_After_And_Analyze (Last (Target_List), Make_DT (E1)); - Exchange_Entities (E1, E2); + Exchange_Declarations (E2); end; end if; @@ -612,6 +613,7 @@ package body Exp_Disp is Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); + Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); -- If the controlling argument is a value of type Ada.Tag or an abstract -- interface class-wide type then use it directly. Otherwise, the tag @@ -1531,6 +1533,7 @@ package body Exp_Disp is Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; Loc : constant Source_Ptr := Sloc (Typ); + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin @@ -1593,46 +1596,78 @@ package body Exp_Disp is Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); - -- Generate: - -- Protected_Entry_Call - -- (T._object'Access, -- Object - -- Protected_Entry_Index! (I), -- E - -- P, -- Uninterpreted_Data - -- Asynchronous_Call, -- Mode - -- Bnn); -- Communication_Block + -- Build T._object'Access for calls below - -- where T is the protected object, I is the entry index, P are - -- the wrapped parameters and B is the name of the communication - -- block. + Obj_Ref := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), - Parameter_Associations => - New_List ( + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => - Make_Attribute_Reference (Loc, -- T._object'Access - Attribute_Name => - Name_Unchecked_Access, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uObject))), + -- Generate: + -- Protected_Entry_Call + -- (T._object'Access, -- Object + -- Protected_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Asynchronous_Call, -- Mode + -- Bnn); -- Communication_Block + + -- where T is the protected object, I is the entry index, P + -- is the wrapped parameters and B is the name of the + -- communication block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), - Make_Identifier (Loc, Name_uP), -- parameter block - New_Reference_To ( -- Asynchronous_Call - RTE (RE_Asynchronous_Call), Loc), + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To ( -- Asynchronous_Call + RTE (RE_Asynchronous_Call), Loc), + + New_Reference_To (Com_Block, Loc)))); -- comm block + + when System_Tasking_Protected_Objects_Single_Entry => + + -- Generate: + -- procedure Protected_Single_Entry_Call + -- (Object : Protection_Entry_Access; + -- Uninterpreted_Data : System.Address; + -- Mode : Call_Modes); - New_Reference_To (Com_Block, Loc)))); -- comm block + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uP), + Attribute_Name => Name_Address), + + New_Reference_To + (RTE (RE_Asynchronous_Call), Loc)))); + + when others => + raise Program_Error; + end case; -- Generate: -- B := Dummy_Communication_Block (Bnn); @@ -1660,7 +1695,7 @@ package body Exp_Disp is -- Asynchronous_Call, -- Mode -- F); -- Rendezvous_Successful - -- where T is the task object, I is the entry index, P are the + -- where T is the task object, I is the entry index, P is the -- wrapped parameters and F is the status flag. Append_To (Stmts, @@ -1669,7 +1704,6 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => New_List ( - Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), @@ -1843,6 +1877,7 @@ package body Exp_Disp is Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin @@ -1929,46 +1964,73 @@ package body Exp_Disp is if Ekind (Conc_Typ) = E_Protected_Type then - -- Generate: - -- Protected_Entry_Call - -- (T._object'Access, -- Object - -- Protected_Entry_Index! (I), -- E - -- P, -- Uninterpreted_Data - -- Conditional_Call, -- Mode - -- Bnn); -- Block + Obj_Ref := -- T._object'Access + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); - -- where T is the protected object, I is the entry index, P are - -- the wrapped parameters and Bnn is the name of the communication - -- block. + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + -- Generate: - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), - Parameter_Associations => - New_List ( + -- Protected_Entry_Call + -- (T._object'Access, -- Object + -- Protected_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Conditional_Call, -- Mode + -- Bnn); -- Block - Make_Attribute_Reference (Loc, -- T._object'Access - Attribute_Name => - Name_Unchecked_Access, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uObject))), + -- where T is the protected object, I is the entry index, P + -- are the wrapped parameters and Bnn is the name of the + -- communication block. - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, - Make_Identifier (Loc, Name_uP), -- parameter block - New_Reference_To ( -- Conditional_Call - RTE (RE_Conditional_Call), Loc), - New_Reference_To ( -- Bnn - Blk_Nam, Loc)))); + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + + New_Reference_To ( -- Conditional_Call + RTE (RE_Conditional_Call), Loc), + New_Reference_To ( -- Bnn + Blk_Nam, Loc)))); + + when System_Tasking_Protected_Objects_Single_Entry => + + -- If we are compiling for a restricted run-time, the call + -- uses the simpler form. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uP), + Attribute_Name => Name_Address), + + New_Reference_To + (RTE (RE_Conditional_Call), Loc)))); + when others => + raise Program_Error; + end case; -- Generate: -- F := not Cancelled (Bnn); @@ -2339,79 +2401,83 @@ package body Exp_Disp is -- A); -- end if; - Append_To (Stmts, - Make_If_Statement (Loc, - Condition => - Make_Identifier (Loc, Name_uF), - - Then_Statements => - New_List ( - - -- Call to Requeue_Protected_Entry - - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - RTE (RE_Requeue_Protected_Entry), Loc), - Parameter_Associations => - New_List ( - - Make_Unchecked_Type_Conversion (Loc, -- PEA (P) - Subtype_Mark => - New_Reference_To ( - RTE (RE_Protection_Entries_Access), Loc), - Expression => - Make_Identifier (Loc, Name_uP)), - - Make_Attribute_Reference (Loc, -- O._object'Acc - Attribute_Name => - Name_Unchecked_Access, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uO), - Selector_Name => - Make_Identifier (Loc, Name_uObject))), + if Restriction_Active (No_Entry_Queue) then + Append_To (Stmts, Make_Null_Statement (Loc)); + else + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Identifier (Loc, Name_uF), - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To ( - RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Then_Statements => + New_List ( - Make_Identifier (Loc, Name_uA)))), -- abort status + -- Call to Requeue_Protected_Entry - Else_Statements => - New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Requeue_Protected_Entry), Loc), + Parameter_Associations => + New_List ( + + Make_Unchecked_Type_Conversion (Loc, -- PEA (P) + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protection_Entries_Access), Loc), + Expression => + Make_Identifier (Loc, Name_uP)), + + Make_Attribute_Reference (Loc, -- O._object'Acc + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uO), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), - -- Call to Requeue_Task_To_Protected_Entry + Make_Identifier (Loc, Name_uA)))), -- abort status - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - RTE (RE_Requeue_Task_To_Protected_Entry), Loc), - Parameter_Associations => - New_List ( + Else_Statements => + New_List ( - Make_Attribute_Reference (Loc, -- O._object'Acc - Attribute_Name => - Name_Unchecked_Access, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uO), - Selector_Name => - Make_Identifier (Loc, Name_uObject))), + -- Call to Requeue_Task_To_Protected_Entry - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To ( - RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Requeue_Task_To_Protected_Entry), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- O._object'Acc + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uO), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), - Make_Identifier (Loc, Name_uA)))))); -- abort status + Make_Identifier (Loc, Name_uA)))))); -- abort status + end if; else pragma Assert (Is_Task_Type (Conc_Typ)); @@ -2658,6 +2724,7 @@ package body Exp_Disp is Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; begin @@ -2727,48 +2794,83 @@ package body Exp_Disp is New_Reference_To (DT_Ptr, Loc)), Make_Identifier (Loc, Name_uS))))); + -- Protected case + if Ekind (Conc_Typ) = E_Protected_Type then - -- Generate: - -- Timed_Protected_Entry_Call ( - -- T._object'access, + -- Build T._object'Access + + Obj_Ref := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); + + -- Normal case, No_Entry_Queue restriction not active. In this + -- case we generate: + + -- Timed_Protected_Entry_Call + -- (T._object'access, -- Protected_Entry_Index! (I), - -- P, - -- D, - -- M, - -- F); + -- P, D, M, F); -- where T is the protected object, I is the entry index, P are -- the wrapped parameters, D is the delay amount, M is the delay -- mode and F is the status flag. - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), - Parameter_Associations => - New_List ( + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), - Make_Attribute_Reference (Loc, -- T._object'access - Attribute_Name => - Name_Unchecked_Access, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uObject))), + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + when System_Tasking_Protected_Objects_Single_Entry => + -- Generate: - Make_Identifier (Loc, Name_uP), -- parameter block - Make_Identifier (Loc, Name_uD), -- delay - Make_Identifier (Loc, Name_uM), -- delay mode - Make_Identifier (Loc, Name_uF)))); -- status flag + -- Timed_Protected_Single_Entry_Call + -- (T._object'access, P, D, M, F); + + -- where T is the protected object, P is the wrapped + -- parameters, D is the delay amount, M is the delay mode, F + -- is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + + when others => + raise Program_Error; + end case; + + -- Task case else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); @@ -2957,12 +3059,13 @@ package body Exp_Disp is -- generate forward references and statically allocate the table. procedure Make_Secondary_DT - (Typ : Entity_Id; - Iface : Entity_Id; - Num_Iface_Prims : Nat; - Iface_DT_Ptr : Entity_Id; - Build_Thunks : Boolean; - Result : List_Id); + (Typ : Entity_Id; + Iface : Entity_Id; + Num_Iface_Prims : Nat; + Iface_DT_Ptr : Entity_Id; + Predef_Prims_Ptr : Entity_Id; + Build_Thunks : Boolean; + Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch -- Table of Typ associated with Iface. Each abstract interface of Typ -- has two secondary dispatch tables: one containing pointers to thunks @@ -3024,12 +3127,13 @@ package body Exp_Disp is ----------------------- procedure Make_Secondary_DT - (Typ : Entity_Id; - Iface : Entity_Id; - Num_Iface_Prims : Nat; - Iface_DT_Ptr : Entity_Id; - Build_Thunks : Boolean; - Result : List_Id) + (Typ : Entity_Id; + Iface : Entity_Id; + Num_Iface_Prims : Nat; + Iface_DT_Ptr : Entity_Id; + Predef_Prims_Ptr : Entity_Id; + Build_Thunks : Boolean; + Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Name_DT : constant Name_Id := New_Internal_Name ('T'); @@ -3168,9 +3272,10 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim_Table (J), Loc), - Attribute_Name => Name_Address); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); @@ -3451,9 +3556,10 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim_Table (J), Loc), - Attribute_Name => Name_Address); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); @@ -3513,6 +3619,30 @@ package body Exp_Disp is (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + + -- Mark entities containing library level static dispatch tables. + -- This attribute is later propagated to all the access-to-subprogram + -- itypes generated to fill the dispatch table slots (see exp_attr). + + if Building_Static_DT (Typ) then + Set_Is_Static_Dispatch_Table_Entity (Predef_Prims); + Set_Is_Static_Dispatch_Table_Entity (Iface_DT); + end if; end Make_Secondary_DT; -- Local variables @@ -3535,10 +3665,7 @@ package body Exp_Disp is Nb_Prim : Nat := 0; New_Node : Node_Id; No_Reg : Node_Id; - Null_Parent_Tag : Boolean := False; Num_Ifaces : Nat := 0; - Old_Tag1 : Node_Id; - Old_Tag2 : Node_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; @@ -3686,7 +3813,8 @@ package body Exp_Disp is Collect_Interface_Components (Typ, Typ_Comps); Suffix_Index := 0; - AI_Tag_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + AI_Tag_Elmt := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop @@ -3699,10 +3827,15 @@ package body Exp_Disp is Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => True, Result => Result); Next_Elmt (AI_Tag_Elmt); + -- Skip the secondary dispatch table of predefined primitives + + Next_Elmt (AI_Tag_Elmt); + -- Build the secondary table containing pointers to primitives -- (used to give support to Generic Dispatching Constructors). @@ -3712,10 +3845,15 @@ package body Exp_Disp is Num_Iface_Prims => UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => False, Result => Result); Next_Elmt (AI_Tag_Elmt); + -- Skip the secondary dispatch table of predefined primitives + + Next_Elmt (AI_Tag_Elmt); + Suffix_Index := Suffix_Index + 1; Next_Elmt (AI_Tag_Comp); end loop; @@ -3850,6 +3988,23 @@ package body Exp_Disp is New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); end if; end if; @@ -4245,7 +4400,9 @@ package body Exp_Disp is Sec_DT_Tag := New_Reference_To (DT_Ptr, Loc); else - Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + Elmt := + Next_Elmt + (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); pragma Assert (Has_Thunks (Node (Elmt))); while Ekind (Node (Elmt)) = E_Constant @@ -4254,14 +4411,20 @@ package body Exp_Disp is loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); + pragma Assert (Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + pragma Assert (not Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); pragma Assert (not Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); end loop; pragma Assert (Ekind (Node (Elmt)) = E_Constant - and then not Has_Thunks (Node (Next_Elmt (Elmt)))); + and then not + Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); Sec_DT_Tag := - New_Reference_To (Node (Next_Elmt (Elmt)), Loc); + New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))), + Loc); end if; Append_To (TSD_Ifaces_List, @@ -4645,9 +4808,10 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim_Table (J), Loc), - Attribute_Name => Name_Address); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; @@ -4787,9 +4951,10 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim_Table (J), Loc), - Attribute_Name => Name_Address); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); else New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); end if; @@ -4871,6 +5036,12 @@ package body Exp_Disp is (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; + -- Inherit the dispatch tables of the parent + + -- There is no need to inherit anything from the parent when building + -- static dispatch tables because the whole dispatch table (including + -- inherited primitives) has been already built. + if Building_Static_DT (Typ) then null; @@ -4880,60 +5051,52 @@ package body Exp_Disp is elsif Is_CPP_Class (Etype (Typ)) then null; - -- Otherwise we fill in the dispatch tables here + -- Otherwise we fill in the dispatch tables here else - if Typ = Etype (Typ) - or else Is_CPP_Class (Etype (Typ)) - or else Is_Interface (Typ) - then - Null_Parent_Tag := True; - - Old_Tag1 := - Unchecked_Convert_To (RTE (RE_Tag), - Make_Integer_Literal (Loc, 0)); - Old_Tag2 := - Unchecked_Convert_To (RTE (RE_Tag), - Make_Integer_Literal (Loc, 0)); - - else - Old_Tag1 := - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); - Old_Tag2 := - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); - end if; - if Typ /= Etype (Typ) and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table - if not Is_Interface (Etype (Typ)) then - if not Null_Parent_Tag then - declare - Nb_Prims : constant Int := - UI_To_Int (DT_Entry_Count - (First_Tag_Component (Etype (Typ)))); - begin + if not Is_Interface (Typ) + and then not Is_Interface (Etype (Typ)) + and then not Is_CPP_Class (Etype (Typ)) + then + declare + Nb_Prims : constant Int := + UI_To_Int (DT_Entry_Count + (First_Tag_Component (Etype (Typ)))); + begin + Append_To (Elab_Code, + Build_Inherit_Predefined_Prims (Loc, + Old_Tag_Node => + New_Reference_To + (Node + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Etype (Typ))))), Loc), + New_Tag_Node => + New_Reference_To + (Node + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))), Loc))); + + if Nb_Prims /= 0 then Append_To (Elab_Code, - Build_Inherit_Predefined_Prims (Loc, - Old_Tag_Node => Old_Tag1, - New_Tag_Node => - New_Reference_To (DT_Ptr, Loc))); - - if Nb_Prims /= 0 then - Append_To (Elab_Code, - Build_Inherit_Prims (Loc, - Typ => Typ, - Old_Tag_Node => Old_Tag2, - New_Tag_Node => New_Reference_To (DT_Ptr, Loc), - Num_Prims => Nb_Prims)); - end if; - end; - end if; + Build_Inherit_Prims (Loc, + Typ => Typ, + Old_Tag_Node => + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Etype (Typ)))), Loc), + New_Tag_Node => New_Reference_To (DT_Ptr, Loc), + Num_Prims => Nb_Prims)); + end if; + end; end if; -- Inherit the secondary dispatch tables of the ancestor @@ -4942,12 +5105,14 @@ package body Exp_Disp is declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt + (Next_Elmt (First_Elmt - (Access_Disp_Table (Etype (Typ)))); + (Access_Disp_Table (Etype (Typ))))); Sec_DT_Typ : Elmt_Id := Next_Elmt - (First_Elmt - (Access_Disp_Table (Typ))); + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))); procedure Copy_Secondary_DTs (Typ : Entity_Id); -- Local procedure required to climb through the ancestors @@ -4998,12 +5163,15 @@ package body Exp_Disp is Build_Inherit_Predefined_Prims (Loc, Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node (Sec_DT_Ancestor), Loc)), + New_Reference_To + (Node + (Next_Elmt (Sec_DT_Ancestor)), + Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Node (Sec_DT_Typ), Loc)))); + (Node (Next_Elmt (Sec_DT_Typ)), + Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, @@ -5027,6 +5195,12 @@ package body Exp_Disp is Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + if not Is_Interface (Etype (Typ)) then -- Inherit second secondary dispatch table @@ -5036,11 +5210,14 @@ package body Exp_Disp is Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Node (Sec_DT_Ancestor), Loc)), + (Node + (Next_Elmt (Sec_DT_Ancestor)), + Loc)), New_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Node (Sec_DT_Typ), Loc)))); + (Node (Next_Elmt (Sec_DT_Typ)), + Loc)))); if Num_Prims /= 0 then Append_To (Elab_Code, @@ -5064,6 +5241,13 @@ package body Exp_Disp is Next_Elmt (Sec_DT_Ancestor); Next_Elmt (Sec_DT_Typ); + + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + Next_Elmt (Iface); end if; @@ -5143,6 +5327,15 @@ package body Exp_Disp is Make_Select_Specific_Data_Table (Typ)); end if; + -- Mark entities containing library level static dispatch tables. This + -- attribute is later propagated to all the access-to-subprogram itypes + -- generated to fill the dispatch table slots (see exp_attr). + + if Building_Static_DT (Typ) then + Set_Is_Static_Dispatch_Table_Entity (Predef_Prims); + Set_Is_Static_Dispatch_Table_Entity (DT); + end if; + Analyze_List (Result, Suppress => All_Checks); Set_Has_Dispatch_Table (Typ); @@ -5312,18 +5505,19 @@ package body Exp_Disp is --------------- function Make_Tags (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Tname : constant Name_Id := Chars (Typ); - Result : constant List_Id := New_List; - AI_Tag_Comp : Elmt_Id; - DT : Node_Id; - DT_Constr_List : List_Id; - DT_Ptr : Node_Id; - Iface_DT_Ptr : Node_Id; - Nb_Prim : Nat; - Suffix_Index : Int; - Typ_Name : Name_Id; - Typ_Comps : Elist_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Tname : constant Name_Id := Chars (Typ); + Result : constant List_Id := New_List; + AI_Tag_Comp : Elmt_Id; + DT : Node_Id; + DT_Constr_List : List_Id; + DT_Ptr : Node_Id; + Predef_Prims_Ptr : Node_Id; + Iface_DT_Ptr : Node_Id; + Nb_Prim : Nat; + Suffix_Index : Int; + Typ_Name : Name_Id; + Typ_Comps : Elist_Id; begin -- 1) Generate the primary and secondary tag entities @@ -5334,18 +5528,28 @@ package body Exp_Disp is Collect_Interface_Components (Typ, Typ_Comps); end if; - -- 1) Generate the primary tag entity + -- 1) Generate the primary tag entities + + -- Primary dispatch table containing user-defined primitives DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); Set_Etype (DT_Ptr, RTE (RE_Tag)); + -- Primary dispatch table containing predefined primitives + + Predef_Prims_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'Y')); + Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); + -- Import the forward declaration of the Dispatch Table wrapper record -- (Make_DT will take care of its exportation) if Building_Static_DT (Typ) then - DT := Make_Defining_Identifier (Loc, - New_External_Name (Tname, 'T')); + DT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'T')); -- Generate: -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); @@ -5371,6 +5575,7 @@ package body Exp_Disp is Set_Dispatch_Table_Wrapper (Typ, DT); if Has_DT (Typ) then + -- Calculate the number of primitives of the dispatch table and -- the size of the Type_Specific_Data record. @@ -5415,6 +5620,22 @@ package body Exp_Disp is (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + -- No dispatch table required else @@ -5450,6 +5671,7 @@ package body Exp_Disp is pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); -- 2) Generate the secondary tag entities @@ -5471,6 +5693,9 @@ package body Exp_Disp is Typ_Name := Name_Find; + -- Secondary dispatch table referencing thunks to user-defined + -- primitives covered by this interface. + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'P')); @@ -5484,6 +5709,25 @@ package body Exp_Disp is (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + -- Secondary dispatch table referencing thunks to predefined + -- primitives. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Y')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Typ_Name, 'D')); @@ -5496,6 +5740,20 @@ package body Exp_Disp is (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + -- Secondary dispatch table referencing predefined primitives + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Z')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + Next_Elmt (AI_Tag_Comp); end loop; end if; @@ -5703,33 +5961,38 @@ package body Exp_Disp is end if; if not Present (Abstract_Interface_Alias (Prim)) then - Typ := Scope (DTC_Entity (Prim)); - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - Pos := DT_Position (Prim); - Tag := First_Tag_Component (Typ); + Typ := Scope (DTC_Entity (Prim)); + Pos := DT_Position (Prim); + Tag := First_Tag_Component (Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then + DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); Insert_After (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, - Address_Node => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address))); + Address_Node => + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Insert_After (Ins_Nod, Build_Set_Prim_Op_Address (Loc, Typ => Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, - Address_Node => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Address))); + Address_Node => + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); end if; -- Ada 2005 (AI-251): Primitive associated with an interface type @@ -5763,35 +6026,40 @@ package body Exp_Disp is Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); - Iface_Prim := Abstract_Interface_Alias (Prim); - Pos := DT_Position (Iface_Prim); - Tag := First_Tag_Component (Iface_Typ); - L := New_List; + Iface_Prim := Abstract_Interface_Alias (Prim); + Pos := DT_Position (Iface_Prim); + Tag := First_Tag_Component (Iface_Typ); + L := New_List; if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address))); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Alias (Prim), Loc), - Attribute_Name => Name_Address))); + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Alias (Prim), Loc), + Attribute_Name => Name_Unrestricted_Access)))); Insert_Actions_After (Ins_Nod, L); @@ -5804,12 +6072,14 @@ package body Exp_Disp is Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, - Address_Node => Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Thunk_Id, Loc), - Attribute_Name => Name_Address))); + Address_Node => + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (not Has_Thunks (Iface_DT_Ptr)); @@ -5818,10 +6088,11 @@ package body Exp_Disp is Typ => Iface_Typ, Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, - Address_Node => Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Alias (Prim), Loc), - Attribute_Name => Name_Address))); + Address_Node => + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Alias (Prim), Loc), + Attribute_Name => Name_Unrestricted_Access)))); Insert_Actions_After (Ins_Nod, L); end if; @@ -5980,8 +6251,9 @@ package body Exp_Disp is end loop; declare - Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean - := (others => False); + Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := + (others => False); + E : Entity_Id; procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); @@ -6231,7 +6503,7 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); -- At this point all the primitives MUST have a position - -- in the dispatch table + -- in the dispatch table. if DT_Position (Prim) = No_Uint then raise Program_Error; @@ -6322,8 +6594,7 @@ package body Exp_Disp is Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); -- The derived type must have at least as many components as its parent - -- (for root types, the Etype points back to itself and the test cannot - -- fail) + -- (for root types Etype points to itself and the test cannot fail). if DT_Entry_Count (The_Tag) < DT_Entry_Count (First_Tag_Component (Parent_Typ)) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f3b9ee2f199..28f6d6e0d9f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -948,6 +948,43 @@ package body Exp_Util is end if; end Component_May_Be_Bit_Aligned; + ----------------------------------- + -- Corresponding_Runtime_Package -- + ----------------------------------- + + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is + Pkg_Id : RTU_Id := RTU_Null; + + begin + pragma Assert (Is_Concurrent_Type (Typ)); + + if Ekind (Typ) in Protected_Kind then + if Has_Entries (Typ) + or else Has_Interrupt_Handler (Typ) + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Typ)))) + then + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Typ) > 1 + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + then + Pkg_Id := System_Tasking_Protected_Objects_Entries; + else + Pkg_Id := System_Tasking_Protected_Objects_Single_Entry; + end if; + + else + Pkg_Id := System_Tasking_Protected_Objects; + end if; + end if; + + return Pkg_Id; + end Corresponding_Runtime_Package; + ------------------------------- -- Convert_To_Actual_Subtype -- ------------------------------- @@ -1384,6 +1421,10 @@ package body Exp_Util is return; end if; + -- Document what is going on here, why four Next's??? + + Next_Elmt (ADT); + Next_Elmt (ADT); Next_Elmt (ADT); Next_Elmt (ADT); Next_Elmt (AI_Elmt); @@ -1420,7 +1461,7 @@ package body Exp_Util is (not Is_Class_Wide_Type (Typ) and then Ekind (Typ) /= E_Incomplete_Type); - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); pragma Assert (Present (Node (ADT))); Find_Secondary_Table (Typ); pragma Assert (Found); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 42c8d2ab8f3..737b39728ee 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -212,43 +212,51 @@ package Exp_Util is -- function itself must do its own cleanups. function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; - -- This function is in charge of detecting record components that may cause - -- trouble in the back end if an attempt is made to assign the component. - -- The back end can handle such assignments with no problem if the - -- components involved are small (64-bits or less) records or scalar items - -- (including bit-packed arrays represented with modular types) or are both - -- aligned on a byte boundary (starting on a byte boundary, and occupying - -- an integral number of bytes). + -- This function is in charge of detecting record components that may + -- cause trouble in the back end if an attempt is made to assign the + -- component. The back end can handle such assignments with no problem if + -- the components involved are small (64-bits or less) records or scalar + -- items (including bit-packed arrays represented with modular types) or + -- are both aligned on a byte boundary (starting on a byte boundary, and + -- occupying an integral number of bytes). -- -- However, problems arise for records larger than 64 bits, or for arrays -- (other than bit-packed arrays represented with a modular type) if the -- component starts on a non-byte boundary, or does not occupy an integral - -- number of bytes (i.e. there are some bits possibly shared with fields at - -- the start or beginning of the component). The back end cannot handle + -- number of bytes (i.e. there are some bits possibly shared with fields + -- at the start or beginning of the component). The back end cannot handle -- loading and storing such components in a single operation. -- -- This function is used to detect the troublesome situation. it is - -- conservative in the sense that it produces True unless it knows for sure - -- that the component is safe (as outlined in the first paragraph above). - -- The code generation for record and array assignment checks for trouble - -- using this function, and if so the assignment is generated + -- conservative in the sense that it produces True unless it knows for + -- sure that the component is safe (as outlined in the first paragraph + -- above). The code generation for record and array assignment checks for + -- trouble using this function, and if so the assignment is generated -- component-wise, which the back end is required to handle correctly. -- - -- Note that in GNAT 3, the back end will reject such components anyway, so - -- the hard work in checking for this case is wasted in GNAT 3, but it's - -- harmless, so it is easier to do it in all cases, rather than + -- Note that in GNAT 3, the back end will reject such components anyway, + -- so the hard work in checking for this case is wasted in GNAT 3, but + -- it is harmless, so it is easier to do it in all cases, rather than -- conditionalize it in GNAT 5 or beyond. procedure Convert_To_Actual_Subtype (Exp : Node_Id); - -- The Etype of an expression is the nominal type of the expression, not - -- the actual subtype. Often these are the same, but not always. For - -- example, a reference to a formal of unconstrained type has the + -- The Etype of an expression is the nominal type of the expression, + -- not the actual subtype. Often these are the same, but not always. + -- For example, a reference to a formal of unconstrained type has the -- unconstrained type as its Etype, but the actual subtype is obtained by -- applying the actual bounds. This routine is given an expression, Exp, - -- and (if necessary), replaces it using Rewrite, with a conversion to the - -- actual subtype, building the actual subtype if necessary. If the + -- and (if necessary), replaces it using Rewrite, with a conversion to + -- the actual subtype, building the actual subtype if necessary. If the -- expression is already of the requested type, then it is unchanged. + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id; + -- Return the id of the runtime package that will provide support for + -- concurrent type Typ. Currently only protected types are supported, + -- and the returned value is one of the following: + -- System_Tasking_Protected_Objects + -- System_Tasking_Protected_Objects_Entries + -- System_Tasking_Protected_Objects_Single_Entry + function Current_Sem_Unit_Declarations return List_Id; -- Return the a place where it is fine to insert declarations for the -- current semantic unit. If the unit is a package body, return the diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 344122a0df0..c36805838e6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -1386,12 +1386,15 @@ package body Sem_Util is ADT : Elmt_Id; begin - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); + ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); while Present (ADT) and then Ekind (Node (ADT)) = E_Constant and then Related_Type (Node (ADT)) /= Iface loop - -- Skip the two secondary dispatch tables of Iface + -- Skip the secondary dispatch tables of Iface + + Next_Elmt (ADT); + Next_Elmt (ADT); Next_Elmt (ADT); Next_Elmt (ADT); end loop; @@ -3769,6 +3772,15 @@ package body Sem_Util is return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Node_Id) return Pragma_Id is + begin + return Get_Pragma_Id (Pragma_Name (N)); + end Get_Pragma_Id; + --------------------------- -- Get_Referenced_Object -- --------------------------- @@ -3906,31 +3918,42 @@ package body Sem_Util is ----------------------------- function Has_Abstract_Interfaces - (Tagged_Type : Entity_Id; + (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is Typ : Entity_Id; begin - pragma Assert (Is_Record_Type (Tagged_Type) - and then Is_Tagged_Type (Tagged_Type)); + -- Handle concurrent types - -- Handle concurrent record types + if Is_Concurrent_Type (T) then + Typ := Corresponding_Record_Type (T); + else + Typ := T; + end if; - if Is_Concurrent_Record_Type (Tagged_Type) - and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type)) + if not Present (Typ) + or else not Is_Tagged_Type (Typ) then - return True; + return False; end if; - Typ := Tagged_Type; + pragma Assert (Is_Record_Type (Typ)); -- Handle private types if Use_Full_View - and then Present (Full_View (Tagged_Type)) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Typ) + and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) then - Typ := Full_View (Tagged_Type); + return True; end if; loop @@ -3953,7 +3976,7 @@ package body Sem_Util is -- Protect the frontend against wrong source with cyclic -- derivations - or else Etype (Typ) = Tagged_Type; + or else Etype (Typ) = T; -- Climb to the ancestor type handling private types @@ -8910,8 +8933,9 @@ package body Sem_Util is procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is begin Basic_Set_Convention (E, Val); + if Is_Type (E) - and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind + and then Is_Access_Subprogram_Type (Base_Type (E)) and then Has_Foreign_Convention (E) then Set_Can_Use_Internal_Rep (E, False); @@ -8932,6 +8956,93 @@ package body Sem_Util is Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; + --------------------------- + -- Set_Debug_Info_Needed -- + --------------------------- + + procedure Set_Debug_Info_Needed (T : Entity_Id) is + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); + pragma Inline (Set_Debug_Info_Needed_If_Not_Set); + -- Used to set debug info in a related node if not set already + + -------------------------------------- + -- Set_Debug_Info_Needed_If_Not_Set -- + -------------------------------------- + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is + begin + if Present (E) + and then not Needs_Debug_Info (E) + then + Set_Debug_Info_Needed (E); + end if; + end Set_Debug_Info_Needed_If_Not_Set; + + -- Start of processing for Set_Debug_Info_Needed + + begin + -- Nothing to do if argument is Empty or has Debug_Info_Off set, which + -- indicates that Debug_Info_Needed is never required for the entity. + + if No (T) + or else Debug_Info_Off (T) + then + return; + end if; + + -- Set flag in entity itself. Note that we will go through the following + -- circuitry even if the flag is already set on T. That's intentional, + -- it makes sure that the flag will be set in subsidiary entities. + + Set_Needs_Debug_Info (T); + + -- Set flag on subsidiary entities if not set already + + if Is_Object (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + elsif Is_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + if Is_Record_Type (T) then + declare + Ent : Entity_Id := First_Entity (T); + begin + while Present (Ent) loop + Set_Debug_Info_Needed_If_Not_Set (Ent); + Next_Entity (Ent); + end loop; + end; + + elsif Is_Array_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); + + declare + Indx : Node_Id := First_Index (T); + begin + while Present (Indx) loop + Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); + Indx := Next_Index (Indx); + end loop; + end; + + if Is_Packed (T) then + Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); + end if; + + elsif Is_Access_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); + + elsif Is_Private_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); + + elsif Is_Protected_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); + end if; + end if; + end Set_Debug_Info_Needed; + --------------------------------- -- Set_Entity_With_Style_Check -- --------------------------------- |