From d18b1548fa1bfeab77e60483102b8584080a6ec0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 20 Nov 2014 15:29:05 +0100 Subject: [PATCH] [multiple changes] 2014-11-20 Robert Dewar * exp_attr.adb: Minor reformatting. 2014-11-20 Hristian Kirtchev * exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of all index constracts when the expression is of an array type. 2014-11-20 Bob Duff * s-taskin.ads: Minor comment improvements. 2014-11-20 Bob Duff * exp_ch9.adb: Minor comment fixes. * s-taskin.adb (Initialize): Small simplification: pass System_Domain to Initialize_ATCB instead of passing null and then setting the Domain to System_Domain. This requires moving the creation of System_Domain earlier. * s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for processors that have a True in the Domain. This is necessary if the Domain is not all-True values. 2014-11-20 Ed Schonberg * sem_ch13.adb (Has_Good_Profile): a) An stream attribute for the class-wide type of an interface type is not a primitive operation and is not subject to the restrictions of 13.13. (38/3). b) A stream operation for an interface type must be a null procedure, and it cannot be a function. From-SVN: r217857 --- gcc/ada/ChangeLog | 32 +++++++++++++++ gcc/ada/exp_attr.adb | 2 + gcc/ada/exp_ch9.adb | 6 +-- gcc/ada/exp_util.adb | 79 ++++++++++++++++++++++++++++++-------- gcc/ada/s-taprop-linux.adb | 4 +- gcc/ada/s-taskin.adb | 36 ++++++++++------- gcc/ada/s-taskin.ads | 8 ++-- gcc/ada/sem_ch13.adb | 25 ++++++++---- 8 files changed, 147 insertions(+), 45 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5fcfdc47356..ce9c839881e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2014-11-20 Robert Dewar + + * exp_attr.adb: Minor reformatting. + +2014-11-20 Hristian Kirtchev + + * exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of + all index constracts when the expression is of an array type. + +2014-11-20 Bob Duff + + * s-taskin.ads: Minor comment improvements. + +2014-11-20 Bob Duff + + * exp_ch9.adb: Minor comment fixes. + * s-taskin.adb (Initialize): Small simplification: pass System_Domain + to Initialize_ATCB instead of passing null and then setting the Domain + to System_Domain. This requires moving the creation of System_Domain + earlier. + * s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for + processors that have a True in the Domain. This is necessary if the + Domain is not all-True values. + +2014-11-20 Ed Schonberg + + * sem_ch13.adb (Has_Good_Profile): a) An stream attribute + for the class-wide type of an interface type is not a primitive + operation and is not subject to the restrictions of 13.13. (38/3). + b) A stream operation for an interface type must be a null + procedure, and it cannot be a function. + 2014-11-20 Bob Duff * exp_attr.adb (Attribute_Max_Size_In_Storage_Elements): diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 595c5488b87..663507aa20e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4232,10 +4232,12 @@ package body Exp_Attr is -- retrieve the original attribute reference from the expression. Attr := N; + if Nkind (Attr) = N_Type_Conversion then Attr := Expression (Attr); Conversion_Added := True; end if; + pragma Assert (Nkind (Attr) = N_Attribute_Reference); -- Heap-allocated controlled objects contain two extra pointers which diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9682859feea..4674da70f8a 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -14146,9 +14146,7 @@ package body Exp_Ch9 is -- present, then the dispatching domain is null. If a rep item is -- present, then the dispatching domain is taken from the -- _Dispatching_Domain field of the task value record, which was set - -- from the rep item value. Note that this parameter must not be - -- generated for the restricted profiles since Ravenscar does not - -- allow dispatching domains. + -- from the rep item value. -- Case where Dispatching_Domain rep item applies: use given value @@ -14162,7 +14160,7 @@ package body Exp_Ch9 is Selector_Name => Make_Identifier (Loc, Name_uDispatching_Domain))); - -- No pragma or aspect Dispatching_Domain apply to the task + -- No pragma or aspect Dispatching_Domain applies to the task else Append_To (Args, Make_Null (Loc)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c85593647d0..a833a0ff8af 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6399,22 +6399,24 @@ package body Exp_Util is (E : Node_Id; Unc_Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (E); List_Constr : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (E); D : Entity_Id; - - Full_Subtyp : Entity_Id; - Priv_Subtyp : Entity_Id; - Utyp : Entity_Id; - Full_Exp : Node_Id; + Full_Exp : Node_Id; + Full_Subtyp : Entity_Id; + High_Bound : Entity_Id; + Index_Typ : Entity_Id; + Low_Bound : Entity_Id; + Priv_Subtyp : Entity_Id; + Utyp : Entity_Id; begin if Is_Private_Type (Unc_Typ) and then Has_Unknown_Discriminants (Unc_Typ) then - -- Prepare the subtype completion, Go to base type to - -- find underlying type, because the type may be a generic - -- actual or an explicit subtype. + -- Prepare the subtype completion. Use the base type to find the + -- underlying type because the type may be a generic actual or an + -- explicit subtype. Utyp := Underlying_Type (Base_Type (Unc_Typ)); Full_Subtyp := Make_Temporary (Loc, 'C'); @@ -6451,22 +6453,67 @@ package body Exp_Util is return New_Occurrence_Of (Priv_Subtyp, Loc); elsif Is_Array_Type (Unc_Typ) then + Index_Typ := First_Index (Unc_Typ); for J in 1 .. Number_Dimensions (Unc_Typ) loop - Append_To (List_Constr, - Make_Range (Loc, - Low_Bound => + + -- Capture the bounds of each index constraint in case the context + -- is an object declaration of an unconstrained type initialized + -- by a function call: + + -- Obj : Unconstr_Typ := Func_Call; + + -- This scenario requires secondary scope management and the index + -- constraint cannot depend on the temporary used to capture the + -- result of the function call. + + -- SS_Mark; + -- Temp : Unconstr_Typ_Ptr := Func_Call'reference; + -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last); + -- Obj : S := Temp.all; + -- SS_Release; -- Temp is gone at this point, bounds of S are + -- -- non existent. + + -- The bounds are kept as variables rather than constants because + -- this prevents spurious optimizations down the line. + + -- Generate: + -- Low_Bound : Base_Type (Index_Typ) := E'First (J); + + Low_Bound := Make_Temporary (Loc, 'B'); + Insert_Action (E, + Make_Object_Declaration (Loc, + Defining_Identifier => Low_Bound, + Object_Definition => + New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), + Expression => Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (E), + Prefix => Duplicate_Subexpr_No_Checks (E), Attribute_Name => Name_First, - Expressions => New_List ( - Make_Integer_Literal (Loc, J))), + Expressions => New_List ( + Make_Integer_Literal (Loc, J))))); + + -- Generate: + -- High_Bound : Base_Type (Index_Typ) := E'Last (J); - High_Bound => + High_Bound := Make_Temporary (Loc, 'B'); + Insert_Action (E, + Make_Object_Declaration (Loc, + Defining_Identifier => High_Bound, + Object_Definition => + New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), + Expression => Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_No_Checks (E), Attribute_Name => Name_Last, Expressions => New_List ( Make_Integer_Literal (Loc, J))))); + + Append_To (List_Constr, + Make_Range (Loc, + Low_Bound => New_Occurrence_Of (Low_Bound, Loc), + High_Bound => New_Occurrence_Of (High_Bound, Loc))); + + Index_Typ := Next_Index (Index_Typ); end loop; elsif Is_Class_Wide_Type (Unc_Typ) then diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index ba5c2122ed9..a95013fa676 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -1516,7 +1516,9 @@ package body System.Task_Primitives.Operations is System.OS_Interface.CPU_ZERO (Size, CPU_Set); for Proc in T.Common.Domain'Range loop - System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); + if T.Common.Domain (Proc) then + System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); + end if; end loop; end if; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 5baf1287655..1643e5c56e6 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -205,18 +205,6 @@ package body System.Tasking is then System.Multiprocessors.Not_A_Specific_CPU else System.Multiprocessors.CPU_Range (Main_CPU)); - T := STPO.New_ATCB (0); - Initialize_ATCB - (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU, - null, Task_Info.Unspecified_Task_Info, 0, T, Success); - pragma Assert (Success); - - STPO.Initialize (T); - STPO.Set_Priority (T, T.Common.Base_Priority); - T.Common.State := Runnable; - T.Common.Task_Image_Len := Main_Task_Image'Length; - T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; - -- At program start-up the environment task is allocated to the default -- system dispatching domain. -- Make sure that the processors which are not available are not taken @@ -228,7 +216,27 @@ package body System.Tasking is (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => True); - T.Common.Domain := System_Domain; + T := STPO.New_ATCB (0); + Initialize_ATCB + (Self_ID => null, + Task_Entry_Point => null, + Task_Arg => Null_Address, + Parent => Null_Task, + Elaborated => null, + Base_Priority => Base_Priority, + Base_CPU => Base_CPU, + Domain => System_Domain, + Task_Info => Task_Info.Unspecified_Task_Info, + Stack_Size => 0, + T => T, + Success => Success); + pragma Assert (Success); + + STPO.Initialize (T); + STPO.Set_Priority (T, T.Common.Base_Priority); + T.Common.State := Runnable; + T.Common.Task_Image_Len := Main_Task_Image'Length; + T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; Dispatching_Domain_Tasks := new Array_Allocated_Tasks' diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index ffb96c34640..a89fe6b2a41 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -1178,9 +1178,11 @@ package System.Tasking is Stack_Size : System.Parameters.Size_Type; T : Task_Id; Success : out Boolean); - -- Initialize fields of a TCB and link into global TCB structures Call - -- this only with abort deferred and holding RTS_Lock. Need more - -- documentation, mention T, and describe Success ??? + -- Initialize fields of the TCB for task T, and link into global TCB + -- structures. Call this only with abort deferred and holding + -- RTS_Lock. Self_ID is the calling task (normally the activator of + -- T). Success is set to indicate whether the TCB was successfully + -- initialized. Need more documentation ??? private diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8a0ac8cc0b8..42e64b1287f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3550,10 +3550,19 @@ package body Sem_Ch13 is end if; -- Verify that the prefix of the attribute and the local name for - -- the type of the formal match. + -- the type of the formal match, or one is the class-wide of the + -- other, in the case of a class-wide stream operation. - if Base_Type (Typ) /= Base_Type (Ent) - or else Present (Next_Formal (F)) + if Base_Type (Typ) = Base_Type (Ent) + or else (Is_Class_Wide_Type (Typ) + and then Typ = Class_Wide_Type (Base_Type (Ent))) + then + null; + else + return False; + end if; + + if Present ((Next_Formal (F))) then return False; @@ -3635,12 +3644,14 @@ package body Sem_Ch13 is -- procedure (RM 13.13.2 (38/3)). elsif Is_Interface (U_Ent) + and then not Is_Class_Wide_Type (U_Ent) and then not Inside_A_Generic - and then Ekind (Subp) = E_Procedure and then - not Null_Present - (Specification - (Unit_Declaration_Node (Ultimate_Alias (Subp)))) + (Ekind (Subp) = E_Function + or else + not Null_Present + (Specification + (Unit_Declaration_Node (Ultimate_Alias (Subp))))) then Error_Msg_N ("stream subprogram for interface type " -- 2.30.2