From 529749b9480f8690c8474cd782664a2d38459ad2 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 22 May 2018 13:26:28 +0000 Subject: [PATCH] [Ada] In-place initialization for Initialize_Scalars This patch optimizes the initialization and allocation of scalar array objects when pragma Initialize_Scalars is in effect. The patch also extends the syntax and semantics of pragma Initialize_Scalars to allow for the specification of invalid values pertaining to families of scalar types. The new syntax is as follows: pragma Initialize_Scalars [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ]; TYPE_VALUE_PAIR ::= SCALAR_TYPE => static_EXPRESSION SCALAR_TYPE := Short_Float | Float | Long_Float | Long_Long_Flat | Signed_8 | Signed_16 | Signed_32 | Signed_64 | Unsigned_8 | Unsigned_16 | Unsigned_32 | Unsigned_64 Depending on the value specified by pragma Initialize_Scalars, the backend may optimize the creation of the scalar array object into a fast memset. ------------ -- Source -- ------------ -- gnat.adc pragma Initialize_Scalars (Short_Float => 0.0, Float => 0.0, Long_Float => 0.0, Long_Long_Float => 0.0, Signed_8 => 0, Signed_16 => 0, Signed_32 => 0, Signed_64 => 0, Unsigned_8 => 0, Unsigned_16 => 0, Unsigned_32 => 0, Unsigned_64 => 0); -- types.ads with System; package Types is Max : constant := 10_000; subtype Big is Integer range 1 .. Max; type Byte is range 0 .. 255; for Byte'Size use System.Storage_Unit; type Byte_Arr_1 is array (1 .. Max) of Byte; type Byte_Arr_2 is array (Big) of Byte; type Byte_Arr_3 is array (Integer range <>) of Byte; type Byte_Arr_4 is array (Integer range <>, Integer range <>) of Byte; type Constr_Arr_1 is array (1 .. Max) of Integer; type Constr_Arr_2 is array (Big) of Integer; type Constr_Arr_3 is array (1 .. Max, 1 .. Max) of Integer; type Constr_Arr_4 is array (Big, Big) of Integer; type Unconstr_Arr_1 is array (Integer range <>) of Integer; type Unconstr_Arr_2 is array (Integer range <>, Integer range <>) of Integer; subtype Subt_Arr_1 is Unconstr_Arr_1 (1 .. Max); subtype Subt_Arr_2 is Unconstr_Arr_1 (Big); subtype Subt_Arr_3 is Unconstr_Arr_2 (1 .. Max, 1 .. Max); subtype Subt_Arr_4 is Unconstr_Arr_2 (Big, Big); subtype Subt_Str_1 is String (1 .. Max); subtype Subt_Str_2 is String (Big); type Byte_Arr_1_Ptr is access Byte_Arr_1; type Byte_Arr_2_Ptr is access Byte_Arr_2; type Byte_Arr_3_Ptr is access Byte_Arr_3; type Byte_Arr_4_Ptr is access Byte_Arr_4; type Constr_Arr_1_Ptr is access Constr_Arr_1; type Constr_Arr_2_Ptr is access Constr_Arr_2; type Constr_Arr_3_Ptr is access Constr_Arr_3; type Constr_Arr_4_Ptr is access Constr_Arr_4; type Unconstr_Arr_1_Ptr is access Unconstr_Arr_1; type Unconstr_Arr_2_Ptr is access Unconstr_Arr_2; type Subt_Arr_1_Ptr is access Subt_Arr_1; type Subt_Arr_2_Ptr is access Subt_Arr_2; type Subt_Arr_3_Ptr is access Subt_Arr_3; type Subt_Arr_4_Ptr is access Subt_Arr_4; type Str_Ptr is access String; type Subt_Str_1_Ptr is access Subt_Str_1; type Subt_Str_2_Ptr is access Subt_Str_2; end Types; -- main.adb with Types; use Types; procedure Main is Byte_Arr_1_Obj : Byte_Arr_1; Byte_Arr_2_Obj : Byte_Arr_2; Byte_Arr_3_Obj : Byte_Arr_3 (1 .. Max); Byte_Arr_4_Obj : Byte_Arr_3 (Big); Byte_Arr_5_Obj : Byte_Arr_4 (1 .. Max, 1 .. Max); Byte_Arr_6_Obj : Byte_Arr_4 (Big, Big); Constr_Arr_1_Obj : Constr_Arr_1; Constr_Arr_2_Obj : Constr_Arr_2; Constr_Arr_3_Obj : Constr_Arr_3; Constr_Arr_4_Obj : Constr_Arr_4; Unconstr_Arr_1_Obj : Unconstr_Arr_1 (1 .. Max); Unconstr_Arr_2_Obj : Unconstr_Arr_1 (Big); Unconstr_Arr_3_Obj : Unconstr_Arr_2 (1 .. Max, 1 .. Max); Unconstr_Arr_4_Obj : Unconstr_Arr_2 (Big, Big); Subt_Arr_1_Obj : Subt_Arr_1; Subt_Arr_2_Obj : Subt_Arr_2; Subt_Arr_3_Obj : Subt_Arr_3; Subt_Arr_4_Obj : Subt_Arr_4; Str_1_Obj : String (1 .. Max); Str_2_Obj : String (Big); Subt_Str_1_Obj : Subt_Str_1; Subt_Str_2_Obj : Subt_Str_2; Byte_Arr_1_Ptr_Obj : Byte_Arr_1_Ptr := new Byte_Arr_1; Byte_Arr_2_Ptr_Obj : Byte_Arr_2_Ptr := new Byte_Arr_2; Byte_Arr_3_Ptr_Obj : Byte_Arr_3_Ptr := new Byte_Arr_3 (1 .. Max); Byte_Arr_4_Ptr_Obj : Byte_Arr_3_Ptr := new Byte_Arr_3 (Big); Byte_Arr_5_Ptr_Obj : Byte_Arr_4_Ptr := new Byte_Arr_4 (1 .. Max, 1 .. Max); Byte_Arr_6_Ptr_Obj : Byte_Arr_4_Ptr := new Byte_Arr_4 (Big, Big); Constr_Arr_1_Ptr_Obj : Constr_Arr_1_Ptr := new Constr_Arr_1; Constr_Arr_2_Ptr_Obj : Constr_Arr_2_Ptr := new Constr_Arr_2; Constr_Arr_3_Ptr_Obj : Constr_Arr_3_Ptr := new Constr_Arr_3; Constr_Arr_4_Ptr_Obj : Constr_Arr_4_Ptr := new Constr_Arr_4; Unconstr_Arr_1_Ptr_Obj : Unconstr_Arr_1_Ptr := new Unconstr_Arr_1 (1 .. Max); Unconstr_Arr_2_Ptr_Obj : Unconstr_Arr_1_Ptr := new Unconstr_Arr_1 (Big); Unconstr_Arr_3_Ptr_Obj : Unconstr_Arr_2_Ptr := new Unconstr_Arr_2 (1 .. Max, 1 .. Max); Unconstr_Arr_4_Ptr_Obj : Unconstr_Arr_2_Ptr := new Unconstr_Arr_2 (Big, Big); Subt_Arr_1_Ptr_Obj : Subt_Arr_1_Ptr := new Subt_Arr_1; Subt_Arr_2_Ptr_Obj : Subt_Arr_2_Ptr := new Subt_Arr_2; Subt_Arr_3_Ptr_Obj : Subt_Arr_3_Ptr := new Subt_Arr_3; Subt_Arr_4_Ptr_Obj : Subt_Arr_4_Ptr := new Subt_Arr_4; Str_Ptr_1_Obj : Str_Ptr := new String (1 .. Max); Str_Ptr_2_Obj : Str_Ptr := new String (Big); Subt_Str_1_Ptr_Obj : Subt_Str_1_Ptr := new Subt_Str_1; Subt_Str_2_Ptr_Obj : Subt_Str_2_Ptr := new Subt_Str_2; begin null; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c -S -gnatDG -gnatws main.adb $ grep -c "others => types__TbyteB!(0));" main.adb.dg $ grep -c "others => integer!(0));" main.adb.dg $ grep -c "others => character!(0));" main.adb.dg $ grep -c "others => types__TbyteB!(0));" main.adb.dg $ grep -c "memset" main.s 8 12 8 8 44 2018-05-22 Hristian Kirtchev gcc/ada/ * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Strip away any conversions before extracting the value of the expression. * exp_ch3.adb (Default_Initialize_Object): Optimize the default initialization of an array of scalars. (Get_Simple_Init_Val): Add processing for array types. Remove the processing of strings because this case is already handled by the array case. (Needs_Simple_Initialization): Moved to Sem_Util. (Simple_Init_Array_Type): New routine. (Simple_Init_Initialize_Scalars_Type): Reimplemented to use the new facilities from Sem_Util. (Simple_Initialization_OK): New routine. * exp_ch3.ads (Needs_Simple_Initialization): Moved to Sem_Util. * exp_ch4.adb (Expand_N_Allocator): Optimize the default allocation of an array of scalars. * sem_prag.adb (Analyze_Float_Value): New routine. (Analyze_Integer_Value): New routine. (Analyze_Pragma): Reimplement the analysis of pragma Initialize_Scalars to handled the extended form of the pragma. (Analyze_Type_Value_Pair): New routine. * sem_util.adb: Add invalid value-related data structures. (Examine_Array_Bounds): New routine. (Has_Static_Array_Bounds): Reimplemented. (Has_Static_Non_Empty_Array_Bounds): New routine. (Invalid_Scalar_Value): New routine. (Needs_Simple_Initialization): Moved from Exp_Ch3. (Set_Invalid_Scalar_Value): New routines. * sem_util.ads (Has_Static_Non_Empty_Array_Bounds): New routine. (Invalid_Scalar_Value): New routine. (Needs_Simple_Initialization): Moved from Exp_Ch3. (Set_Invalid_Scalar_Value): New routines. * snames.ads-tmpl: Add names for the salar type families used by pragma Initialize_Scalars. From-SVN: r260529 --- gcc/ada/ChangeLog | 36 ++++ gcc/ada/exp_aggr.adb | 18 +- gcc/ada/exp_ch3.adb | 271 ++++++++++++++------------- gcc/ada/exp_ch3.ads | 13 -- gcc/ada/exp_ch4.adb | 63 ++++++- gcc/ada/sem_prag.adb | 180 +++++++++++++++++- gcc/ada/sem_util.adb | 394 ++++++++++++++++++++++++++++++++++------ gcc/ada/sem_util.ads | 35 ++++ gcc/ada/snames.ads-tmpl | 24 +++ 9 files changed, 830 insertions(+), 204 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ebfe6d4417c..748e4a4bb77 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2018-05-22 Hristian Kirtchev + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Strip away any + conversions before extracting the value of the expression. + * exp_ch3.adb (Default_Initialize_Object): Optimize the default + initialization of an array of scalars. + (Get_Simple_Init_Val): Add processing for array types. Remove the + processing of strings because this case is already handled by the array + case. + (Needs_Simple_Initialization): Moved to Sem_Util. + (Simple_Init_Array_Type): New routine. + (Simple_Init_Initialize_Scalars_Type): Reimplemented to use the new + facilities from Sem_Util. + (Simple_Initialization_OK): New routine. + * exp_ch3.ads (Needs_Simple_Initialization): Moved to Sem_Util. + * exp_ch4.adb (Expand_N_Allocator): Optimize the default allocation of + an array of scalars. + * sem_prag.adb (Analyze_Float_Value): New routine. + (Analyze_Integer_Value): New routine. + (Analyze_Pragma): Reimplement the analysis of pragma Initialize_Scalars + to handled the extended form of the pragma. + (Analyze_Type_Value_Pair): New routine. + * sem_util.adb: Add invalid value-related data structures. + (Examine_Array_Bounds): New routine. + (Has_Static_Array_Bounds): Reimplemented. + (Has_Static_Non_Empty_Array_Bounds): New routine. + (Invalid_Scalar_Value): New routine. + (Needs_Simple_Initialization): Moved from Exp_Ch3. + (Set_Invalid_Scalar_Value): New routines. + * sem_util.ads (Has_Static_Non_Empty_Array_Bounds): New routine. + (Invalid_Scalar_Value): New routine. + (Needs_Simple_Initialization): Moved from Exp_Ch3. + (Set_Invalid_Scalar_Value): New routines. + * snames.ads-tmpl: Add names for the salar type families used by pragma + Initialize_Scalars. + 2018-05-22 Javier Miranda * exp_disp.adb (Make_DT): Initialize the External_Tag with an empty diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index f723c1b4d99..975d32ff359 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4918,20 +4918,21 @@ package body Exp_Aggr is -- specifically optimized for the target. function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is + Csiz : Uint; Ctyp : Entity_Id; + Expr : Node_Id; + High : Node_Id; Index : Entity_Id; - Expr : Node_Id := N; Low : Node_Id; - High : Node_Id; - Csiz : Uint; + Nunits : Int; Remainder : Uint; Value : Uint; - Nunits : Nat; begin -- Recurse as far as possible to find the innermost component type Ctyp := Etype (N); + Expr := N; while Is_Array_Type (Ctyp) loop if Nkind (Expr) /= N_Aggregate or else not Is_Others_Aggregate (Expr) @@ -5022,6 +5023,15 @@ package body Exp_Aggr is Analyze_And_Resolve (Expr, Ctyp); + -- Strip away any conversions from the expression as they simply + -- qualify the real expression. + + while Nkind_In (Expr, N_Unchecked_Type_Conversion, + N_Type_Conversion) + loop + Expr := Expression (Expr); + end loop; + Nunits := UI_To_Int (Csiz) / System_Storage_Unit; if Nunits = 1 then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a43166b8881..fe755e3b123 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5936,6 +5936,11 @@ package body Exp_Ch3 is -- Return a new reference to Def_Id with attributes Assignment_OK and -- Must_Not_Freeze already set. + function Simple_Initialization_OK + (Init_Typ : Entity_Id) return Boolean; + -- Determine whether object declaration N with entity Def_Id needs + -- simple initialization, assuming that it is of type Init_Typ. + -------------------------- -- New_Object_Reference -- -------------------------- @@ -5957,6 +5962,28 @@ package body Exp_Ch3 is return Obj_Ref; end New_Object_Reference; + ------------------------------ + -- Simple_Initialization_OK -- + ------------------------------ + + function Simple_Initialization_OK + (Init_Typ : Entity_Id) return Boolean + is + begin + -- Do not consider the object declaration if it comes with an + -- initialization expression, or is internal in which case it + -- will be assigned later. + + return + not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) + and then Needs_Simple_Initialization + (Typ => Init_Typ, + Consider_IS => + Initialize_Scalars + and then No (Following_Address_Clause (N))); + end Simple_Initialization_OK; + -- Local variables Exceptions_OK : constant Boolean := @@ -6041,6 +6068,41 @@ package body Exp_Ch3 is elsif Build_Equivalent_Aggregate then null; + -- Optimize the default initialization of an array object when + -- the following conditions are met: + -- + -- * Pragma Initialize_Scalars or Normalize_Scalars is in + -- effect. + -- + -- * The bounds of the array type are static and lack empty + -- ranges. + -- + -- * The array type does not contain atomic components or is + -- treated as packed. + -- + -- * The component is of a scalar type which requires simple + -- initialization. + -- + -- Construct an in-place initialization aggregate which may be + -- convert into a fast memset by the backend. + + elsif Init_Or_Norm_Scalars + and then Is_Array_Type (Typ) + and then not Has_Atomic_Components (Typ) + and then not Is_Packed (Typ) + and then Has_Static_Non_Empty_Array_Bounds (Typ) + and then Is_Scalar_Type (Component_Type (Typ)) + and then Simple_Initialization_OK (Component_Type (Typ)) + then + Set_No_Initialization (N, False); + Set_Expression (N, + Get_Simple_Init_Val + (Typ => Typ, + N => Obj_Def, + Size => Esize (Def_Id))); + + Analyze_And_Resolve (Expression (N), Typ); + -- Otherwise invoke the type init proc, generate: -- Type_Init_Proc (Obj); @@ -6056,15 +6118,8 @@ package body Exp_Ch3 is end if; -- Provide a default value if the object needs simple initialization - -- and does not already have an initial value. A generated temporary - -- does not require initialization because it will be assigned later. - elsif Needs_Simple_Initialization - (Typ, Initialize_Scalars - and then No (Following_Address_Clause (N))) - and then not Is_Internal (Def_Id) - and then not Has_Init_Expression (N) - then + elsif Simple_Initialization_OK (Typ) then Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val @@ -7954,6 +8009,9 @@ package body Exp_Ch3 is -- * Hi_Bound - Set to No_Unit when there is no information available, -- or to the known high bound. + function Simple_Init_Array_Type return Node_Id; + -- Build an expression to initialize array type Typ + function Simple_Init_Defaulted_Type return Node_Id; -- Build an expression to initialize type Typ which is subject to -- aspect Default_Value. @@ -7974,9 +8032,6 @@ package body Exp_Ch3 is function Simple_Init_Scalar_Type return Node_Id; -- Build an expression to initialize scalar type Typ - function Simple_Init_String_Type return Node_Id; - -- Build an expression to initialize string type Typ - ---------------------------- -- Extract_Subtype_Bounds -- ---------------------------- @@ -8034,6 +8089,57 @@ package body Exp_Ch3 is end loop; end Extract_Subtype_Bounds; + ---------------------------- + -- Simple_Init_Array_Type -- + ---------------------------- + + function Simple_Init_Array_Type return Node_Id is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + + function Simple_Init_Dimension (Index : Node_Id) return Node_Id; + -- Initialize a single array dimension with index constraint Index + + -------------------- + -- Simple_Init_Dimension -- + -------------------- + + function Simple_Init_Dimension (Index : Node_Id) return Node_Id is + begin + -- Process the current dimension + + if Present (Index) then + + -- Build a suitable "others" aggregate for the next dimension, + -- or initialize the component itself. Generate: + -- + -- (others => ...) + + return + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => + Simple_Init_Dimension (Next_Index (Index))))); + + -- Otherwise all dimensions have been processed. Initialize the + -- component itself. + + else + return + Get_Simple_Init_Val + (Typ => Comp_Typ, + N => N, + Size => Esize (Comp_Typ)); + end if; + end Simple_Init_Dimension; + + -- Start of processing for Simple_Init_Array_Type + + begin + return Simple_Init_Dimension (First_Index (Typ)); + end Simple_Init_Array_Type; + -------------------------------- -- Simple_Init_Defaulted_Type -- -------------------------------- @@ -8080,67 +8186,63 @@ package body Exp_Ch3 is Float_Typ : Entity_Id; Hi_Bound : Uint; Lo_Bound : Uint; - Val_RE : RE_Id; + Scal_Typ : Scalar_Id; begin Extract_Subtype_Bounds (Lo_Bound, Hi_Bound); - -- For float types, use float values from System.Scalar_Values + -- Float types if Is_Floating_Point_Type (Typ) then Float_Typ := Root_Type (Typ); if Float_Typ = Standard_Short_Float then - Val_RE := RE_IS_Isf; + Scal_Typ := Name_Short_Float; elsif Float_Typ = Standard_Float then - Val_RE := RE_IS_Ifl; + Scal_Typ := Name_Float; elsif Float_Typ = Standard_Long_Float then - Val_RE := RE_IS_Ilf; + Scal_Typ := Name_Long_Float; else pragma Assert (Float_Typ = Standard_Long_Long_Float); - Val_RE := RE_IS_Ill; + Scal_Typ := Name_Long_Long_Float; end if; - -- If zero is invalid, use zero values from System.Scalar_Values + -- If zero is invalid, it is a convenient value to use that is for + -- sure an appropriate invalid value in all situations. elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then - if Size_To_Use <= 8 then - Val_RE := RE_IS_Iz1; - elsif Size_To_Use <= 16 then - Val_RE := RE_IS_Iz2; - elsif Size_To_Use <= 32 then - Val_RE := RE_IS_Iz4; - else - Val_RE := RE_IS_Iz8; - end if; + return Make_Integer_Literal (Loc, 0); - -- For unsigned, use unsigned values from System.Scalar_Values + -- Unsigned types elsif Is_Unsigned_Type (Typ) then if Size_To_Use <= 8 then - Val_RE := RE_IS_Iu1; + Scal_Typ := Name_Unsigned_8; elsif Size_To_Use <= 16 then - Val_RE := RE_IS_Iu2; + Scal_Typ := Name_Unsigned_16; elsif Size_To_Use <= 32 then - Val_RE := RE_IS_Iu4; + Scal_Typ := Name_Unsigned_32; else - Val_RE := RE_IS_Iu8; + Scal_Typ := Name_Unsigned_64; end if; - -- For signed, use signed values from System.Scalar_Values + -- Signed types else if Size_To_Use <= 8 then - Val_RE := RE_IS_Is1; + Scal_Typ := Name_Signed_8; elsif Size_To_Use <= 16 then - Val_RE := RE_IS_Is2; + Scal_Typ := Name_Signed_16; elsif Size_To_Use <= 32 then - Val_RE := RE_IS_Is4; + Scal_Typ := Name_Signed_32; else - Val_RE := RE_IS_Is8; + Scal_Typ := Name_Signed_64; end if; end if; - return New_Occurrence_Of (RTE (Val_RE), Loc); + -- Use the values specified by pragma Initialize_Scalars or the ones + -- provided by the binder. Higher precedence is given to the pragma. + + return Invalid_Scalar_Value (Loc, Scal_Typ); end Simple_Init_Initialize_Scalars_Type; ---------------------------------------- @@ -8308,29 +8410,6 @@ package body Exp_Ch3 is return Expr; end Simple_Init_Scalar_Type; - ----------------------------- - -- Simple_Init_String_Type -- - ----------------------------- - - function Simple_Init_String_Type return Node_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - - begin - -- Generate: - -- (others => Get_Simple_Init_Value) - - return - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => - Get_Simple_Init_Val - (Typ => Comp_Typ, - N => N, - Size => Esize (Comp_Typ))))); - end Simple_Init_String_Type; - -- Start of processing for Get_Simple_Init_Val begin @@ -8344,11 +8423,11 @@ package body Exp_Ch3 is return Simple_Init_Scalar_Type; end if; - -- [[Wide_]Wide_]String with Initialize or Normalize_Scalars + -- Array type with Initialize or Normalize_Scalars - elsif Is_Standard_String_Type (Typ) then + elsif Is_Array_Type (Typ) then pragma Assert (Init_Or_Norm_Scalars); - return Simple_Init_String_Type; + return Simple_Init_Array_Type; -- Access type is initialized to null @@ -10002,70 +10081,6 @@ package body Exp_Ch3 is end if; end Make_Tag_Assignment; - --------------------------------- - -- Needs_Simple_Initialization -- - --------------------------------- - - function Needs_Simple_Initialization - (Typ : Entity_Id; - Consider_IS : Boolean := True) return Boolean - is - Consider_IS_NS : constant Boolean := - Normalize_Scalars or (Initialize_Scalars and Consider_IS); - - begin - -- Never need initialization if it is suppressed - - if Initialization_Suppressed (Typ) then - return False; - end if; - - -- Check for private type, in which case test applies to the underlying - -- type of the private type. - - if Is_Private_Type (Typ) then - declare - RT : constant Entity_Id := Underlying_Type (Typ); - begin - if Present (RT) then - return Needs_Simple_Initialization (RT); - else - return False; - end if; - end; - - -- Scalar type with Default_Value aspect requires initialization - - elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then - return True; - - -- Cases needing simple initialization are access types, and, if pragma - -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar - -- types. - - elsif Is_Access_Type (Typ) - or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) - then - return True; - - -- If Initialize/Normalize_Scalars is in effect, string objects also - -- need initialization, unless they are created in the course of - -- expanding an aggregate (since in the latter case they will be - -- filled with appropriate initializing values before they are used). - - elsif Consider_IS_NS - and then Is_Standard_String_Type (Typ) - and then - (not Is_Itype (Typ) - or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) - then - return True; - - else - return False; - end if; - end Needs_Simple_Initialization; - ---------------------- -- Predef_Deep_Spec -- ---------------------- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 65faa3136df..d41029dd657 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -134,17 +134,4 @@ package Exp_Ch3 is -- clause the assignment is handled as part of the freezing of the object, -- see Check_Address_Clause. - function Needs_Simple_Initialization - (Typ : Entity_Id; - Consider_IS : Boolean := True) return Boolean; - -- Certain types need initialization even though there is no specific - -- initialization routine: - -- Access types (which need initializing to null) - -- All scalar types if Normalize_Scalars mode set - -- Descendants of standard string types if Normalize_Scalars mode set - -- Scalar types having a Default_Value attribute - -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is - -- set to False, but if Consider_IS is set to True, then the cases above - -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode. - end Exp_Ch3; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b903719bcdd..87a00826a77 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4595,7 +4595,7 @@ package body Exp_Ch4 is -- first argument to Init must be converted to the task record type. declare - T : constant Entity_Id := Entity (Expression (N)); + T : constant Entity_Id := Etype (Expression (N)); Args : List_Id; Decls : List_Id; Decl : Node_Id; @@ -4618,6 +4618,67 @@ package body Exp_Ch4 is Is_Allocate => True); end if; + -- Optimize the default allocation of an array object when the + -- following conditions are met: + -- + -- * Pragma Initialize_Scalars or Normalize_Scalars is in effect + -- + -- * The bounds of the array type are static and lack empty ranges + -- + -- * The array type does not contain atomic components or is + -- treated as packed. + -- + -- * The component is of a scalar type which requires simple + -- initialization. + -- + -- Construct an in-place initialization aggregate which may be + -- convert into a fast memset by the backend. + + elsif Init_Or_Norm_Scalars + and then Is_Array_Type (T) + and then not Has_Atomic_Components (T) + and then not Is_Packed (T) + and then Has_Static_Non_Empty_Array_Bounds (T) + and then Is_Scalar_Type (Component_Type (T)) + and then Needs_Simple_Initialization + (Typ => Component_Type (T), + Consider_IS => True) + then + Set_Analyzed (N); + Temp := Make_Temporary (Loc, 'P'); + + -- Generate: + -- Temp : Ptr_Typ := new ...; + + Insert_Action + (Assoc_Node => N, + Ins_Action => + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (PtrT, Loc), + Expression => Relocate_Node (N)), + Suppress => All_Checks); + + -- Generate: + -- Temp.all := (others => ...); + + Insert_Action + (Assoc_Node => N, + Ins_Action => + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)), + Expression => + Get_Simple_Init_Val + (Typ => T, + N => N, + Size => Esize (Component_Type (T)))), + Suppress => All_Checks); + + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + -- Case of no initialization procedure present elsif not Has_Non_Null_Base_Init_Proc (T) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1c067ba3504..4e256d0db55 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17124,24 +17124,190 @@ package body Sem_Prag is -- Initialize_Scalars -- ------------------------ - -- pragma Initialize_Scalars; + -- pragma Initialize_Scalars + -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ]; + + -- TYPE_VALUE_PAIR ::= + -- SCALAR_TYPE => static_EXPRESSION + + -- SCALAR_TYPE := + -- Short_Float + -- | Float + -- | Long_Float + -- | Long_Long_Flat + -- | Signed_8 + -- | Signed_16 + -- | Signed_32 + -- | Signed_64 + -- | Unsigned_8 + -- | Unsigned_16 + -- | Unsigned_32 + -- | Unsigned_64 + + when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare + Seen : array (Scalar_Id) of Node_Id := (others => Empty); + -- This collection holds the individual pairs which specify the + -- invalid values of their respective scalar types. + + procedure Analyze_Float_Value + (Scal_Typ : Float_Scalar_Id; + Val_Expr : Node_Id); + -- Analyze a type value pair associated with float type Scal_Typ + -- and expression Val_Expr. + + procedure Analyze_Integer_Value + (Scal_Typ : Integer_Scalar_Id; + Val_Expr : Node_Id); + -- Analyze a type value pair associated with integer type Scal_Typ + -- and expression Val_Expr. + + procedure Analyze_Type_Value_Pair (Pair : Node_Id); + -- Analyze type value pair Pair - when Pragma_Initialize_Scalars => + ------------------------- + -- Analyze_Float_Value -- + ------------------------- + + procedure Analyze_Float_Value + (Scal_Typ : Float_Scalar_Id; + Val_Expr : Node_Id) + is + begin + Analyze_And_Resolve (Val_Expr, Any_Real); + + if Is_OK_Static_Expression (Val_Expr) then + Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr)); + + else + Error_Msg_Name_1 := Scal_Typ; + Error_Msg_N ("value for type % must be static", Val_Expr); + end if; + end Analyze_Float_Value; + + --------------------------- + -- Analyze_Integer_Value -- + --------------------------- + + procedure Analyze_Integer_Value + (Scal_Typ : Integer_Scalar_Id; + Val_Expr : Node_Id) + is + begin + Analyze_And_Resolve (Val_Expr, Any_Integer); + + if Is_OK_Static_Expression (Val_Expr) then + Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr)); + + else + Error_Msg_Name_1 := Scal_Typ; + Error_Msg_N ("value for type % must be static", Val_Expr); + end if; + end Analyze_Integer_Value; + + ----------------------------- + -- Analyze_Type_Value_Pair -- + ----------------------------- + + procedure Analyze_Type_Value_Pair (Pair : Node_Id) is + Scal_Typ : constant Name_Id := Chars (Pair); + Val_Expr : constant Node_Id := Expression (Pair); + Prev_Pair : Node_Id; + + begin + if Scal_Typ in Scalar_Id then + Prev_Pair := Seen (Scal_Typ); + + -- Prevent multiple attempts to set a value for a scalar + -- type. + + if Present (Prev_Pair) then + Error_Msg_Name_1 := Scal_Typ; + Error_Msg_N + ("cannot specify multiple invalid values for type %", + Pair); + + Error_Msg_Sloc := Sloc (Prev_Pair); + Error_Msg_N ("previous value set #", Pair); + + -- Ignore the effects of the pair, but do not halt the + -- analysis of the pragma altogether. + + return; + + -- Otherwise capture the first pair for this scalar type + + else + Seen (Scal_Typ) := Pair; + end if; + + if Scal_Typ in Float_Scalar_Id then + Analyze_Float_Value (Scal_Typ, Val_Expr); + + else pragma Assert (Scal_Typ in Integer_Scalar_Id); + Analyze_Integer_Value (Scal_Typ, Val_Expr); + end if; + + -- Otherwise the scalar family is illegal + + else + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("argument of pragma % must denote valid scalar family", + Pair); + end if; + end Analyze_Type_Value_Pair; + + -- Local variables + + Pairs : constant List_Id := Pragma_Argument_Associations (N); + Pair : Node_Id; + + -- Start of processing for Do_Initialize_Scalars + + begin GNAT_Pragma; - Check_Arg_Count (0); Check_Valid_Configuration_Pragma; Check_Restriction (No_Initialize_Scalars, N); + -- Ignore the effects of the pragma when No_Initialize_Scalars is + -- in effect. + + if Restriction_Active (No_Initialize_Scalars) then + null; + -- Initialize_Scalars creates false positives in CodePeer, and -- incorrect negative results in GNATprove mode, so ignore this -- pragma in these modes. - if not Restriction_Active (No_Initialize_Scalars) - and then not (CodePeer_Mode or GNATprove_Mode) - then + elsif CodePeer_Mode or GNATprove_Mode then + null; + + -- Otherwise analyze the pragma + + else + if Present (Pairs) then + + -- Install Standard in order to provide access to primitive + -- types in case the expressions contain attributes such as + -- Integer'Last. + + Push_Scope (Standard_Standard); + + Pair := First (Pairs); + while Present (Pair) loop + Analyze_Type_Value_Pair (Pair); + Next (Pair); + end loop; + + -- Remove Standard + + Pop_Scope; + end if; + Init_Or_Norm_Scalars := True; - Initialize_Scalars := True; + Initialize_Scalars := True; end if; + end Do_Initialize_Scalars; ----------------- -- Initializes -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 97084307949..93ffae3a2c1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -72,6 +72,25 @@ with GNAT.HTable; use GNAT.HTable; package body Sem_Util is + --------------------------- + -- Local Data Structures -- + --------------------------- + + Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty); + -- A collection to hold the entities of the variables declared in package + -- System.Scalar_Values which describe the invalid values of scalar types. + + Invalid_Binder_Values_Set : Boolean := False; + -- This flag prevents multiple attempts to initialize Invalid_Binder_Values + + Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal); + -- A collection to hold the invalid values of float types as specified by + -- pragma Initialize_Scalars. + + Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint); + -- A collection to hold the invalid values of integer types as specified + -- by pragma Initialize_Scalars. + ----------------------- -- Local Subprograms -- ----------------------- @@ -84,6 +103,14 @@ package body Sem_Util is -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, -- Loc is the source location, T is the original subtype. + procedure Examine_Array_Bounds + (Typ : Entity_Id; + All_Static : out Boolean; + Has_Empty : out Boolean); + -- Inspect the index constraints of array type Typ. Flag All_Static is set + -- when all ranges are static. Flag Has_Empty is set only when All_Static + -- is set and indicates that at least one range is empty. + function Has_Enabled_Property (Item_Id : Entity_Id; Property : Name_Id) return Boolean; @@ -7365,6 +7392,91 @@ package body Sem_Util is return Id; end Entity_Of; + -------------------------- + -- Examine_Array_Bounds -- + -------------------------- + + procedure Examine_Array_Bounds + (Typ : Entity_Id; + All_Static : out Boolean; + Has_Empty : out Boolean) + is + function Is_OK_Static_Bound (Bound : Node_Id) return Boolean; + -- Determine whether bound Bound is a suitable static bound + + ------------------------ + -- Is_OK_Static_Bound -- + ------------------------ + + function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is + begin + return + not Error_Posted (Bound) + and then Is_OK_Static_Expression (Bound); + end Is_OK_Static_Bound; + + -- Local variables + + Hi_Bound : Node_Id; + Index : Node_Id; + Lo_Bound : Node_Id; + + -- Start of processing for Examine_Array_Bounds + + begin + -- An unconstrained array type does not have static bounds, and it is + -- not known whether they are empty or not. + + if not Is_Constrained (Typ) then + All_Static := False; + Has_Empty := False; + + -- A string literal has static bounds, and is not empty as long as it + -- contains at least one character. + + elsif Ekind (Typ) = E_String_Literal_Subtype then + All_Static := True; + Has_Empty := String_Literal_Length (Typ) > 0; + end if; + + -- Assume that all bounds are static and not empty + + All_Static := True; + Has_Empty := False; + + -- Examine each index + + Index := First_Index (Typ); + while Present (Index) loop + if Is_Discrete_Type (Etype (Index)) then + Get_Index_Bounds (Index, Lo_Bound, Hi_Bound); + + if Is_OK_Static_Bound (Lo_Bound) + and then + Is_OK_Static_Bound (Hi_Bound) + then + -- The static bounds produce an empty range + + if Is_Null_Range (Lo_Bound, Hi_Bound) then + Has_Empty := True; + end if; + + -- Otherwise at least one of the bounds is not static + + else + All_Static := False; + end if; + + -- Otherwise the index is non-discrete, therefore not static + + else + All_Static := False; + end if; + + Next_Index (Index); + end loop; + end Examine_Array_Bounds; + -------------------------- -- Explain_Limited_Type -- -------------------------- @@ -11372,64 +11484,28 @@ package body Sem_Util is ----------------------------- function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is - Ndims : constant Nat := Number_Dimensions (Typ); - - Index : Node_Id; - Low : Node_Id; - High : Node_Id; + All_Static : Boolean; + Dummy : Boolean; begin - -- Unconstrained types do not have static bounds - - if not Is_Constrained (Typ) then - return False; - end if; - - -- First treat string literals specially, as the lower bound and length - -- of string literals are not stored like those of arrays. - - -- A string literal always has static bounds - - if Ekind (Typ) = E_String_Literal_Subtype then - return True; - end if; - - -- Treat all dimensions in turn - - Index := First_Index (Typ); - for Indx in 1 .. Ndims loop - - -- In case of an illegal index which is not a discrete type, return - -- that the type is not static. - - if not Is_Discrete_Type (Etype (Index)) - or else Etype (Index) = Any_Type - then - return False; - end if; + Examine_Array_Bounds (Typ, All_Static, Dummy); - Get_Index_Bounds (Index, Low, High); + return All_Static; + end Has_Static_Array_Bounds; - if Error_Posted (Low) or else Error_Posted (High) then - return False; - end if; + --------------------------------------- + -- Has_Static_Non_Empty_Array_Bounds -- + --------------------------------------- - if Is_OK_Static_Expression (Low) - and then - Is_OK_Static_Expression (High) - then - null; - else - return False; - end if; + function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is + All_Static : Boolean; + Has_Empty : Boolean; - Next (Index); - end loop; - - -- If we fall through the loop, all indexes matched + begin + Examine_Array_Bounds (Typ, All_Static, Has_Empty); - return True; - end Has_Static_Array_Bounds; + return All_Static and not Has_Empty; + end Has_Static_Non_Empty_Array_Bounds; ---------------- -- Has_Stream -- @@ -12729,6 +12805,124 @@ package body Sem_Util is SPARK_Mode_Pragma := Prag; end Install_SPARK_Mode; + -------------------------- + -- Invalid_Scalar_Value -- + -------------------------- + + function Invalid_Scalar_Value + (Loc : Source_Ptr; + Scal_Typ : Scalar_Id) return Node_Id + is + function Invalid_Binder_Value return Node_Id; + -- Return a reference to the corresponding invalid value for type + -- Scal_Typ as defined in unit System.Scalar_Values. + + function Invalid_Float_Value return Node_Id; + -- Return the invalid value of float type Scal_Typ + + function Invalid_Integer_Value return Node_Id; + -- Return the invalid value of integer type Scal_Typ + + procedure Set_Invalid_Binder_Values; + -- Set the contents of collection Invalid_Binder_Values + + -------------------------- + -- Invalid_Binder_Value -- + -------------------------- + + function Invalid_Binder_Value return Node_Id is + Val_Id : Entity_Id; + + begin + -- Initialize the collection of invalid binder values the first time + -- around. + + Set_Invalid_Binder_Values; + + -- Obtain the corresponding variable from System.Scalar_Values which + -- holds the invalid value for this type. + + Val_Id := Invalid_Binder_Values (Scal_Typ); + pragma Assert (Present (Val_Id)); + + return New_Occurrence_Of (Val_Id, Loc); + end Invalid_Binder_Value; + + ------------------------- + -- Invalid_Float_Value -- + ------------------------- + + function Invalid_Float_Value return Node_Id is + Value : constant Ureal := Invalid_Floats (Scal_Typ); + + begin + -- Pragma Invalid_Scalars did not specify an invalid value for this + -- type. Fall back to the value provided by the binder. + + if Value = No_Ureal then + return Invalid_Binder_Value; + else + return Make_Real_Literal (Loc, Realval => Value); + end if; + end Invalid_Float_Value; + + --------------------------- + -- Invalid_Integer_Value -- + --------------------------- + + function Invalid_Integer_Value return Node_Id is + Value : constant Uint := Invalid_Integers (Scal_Typ); + + begin + -- Pragma Invalid_Scalars did not specify an invalid value for this + -- type. Fall back to the value provided by the binder. + + if Value = No_Uint then + return Invalid_Binder_Value; + else + return Make_Integer_Literal (Loc, Intval => Value); + end if; + end Invalid_Integer_Value; + + ------------------------------- + -- Set_Invalid_Binder_Values -- + ------------------------------- + + procedure Set_Invalid_Binder_Values is + begin + if not Invalid_Binder_Values_Set then + Invalid_Binder_Values_Set := True; + + -- Initialize the contents of the collection once since RTE calls + -- are not cheap. + + Invalid_Binder_Values := + (Name_Short_Float => RTE (RE_IS_Isf), + Name_Float => RTE (RE_IS_Ifl), + Name_Long_Float => RTE (RE_IS_Ilf), + Name_Long_Long_Float => RTE (RE_IS_Ill), + Name_Signed_8 => RTE (RE_IS_Is1), + Name_Signed_16 => RTE (RE_IS_Is2), + Name_Signed_32 => RTE (RE_IS_Is4), + Name_Signed_64 => RTE (RE_IS_Is8), + Name_Unsigned_8 => RTE (RE_IS_Iu1), + Name_Unsigned_16 => RTE (RE_IS_Iu2), + Name_Unsigned_32 => RTE (RE_IS_Iu4), + Name_Unsigned_64 => RTE (RE_IS_Iu8)); + end if; + end Set_Invalid_Binder_Values; + + -- Start of processing for Invalid_Scalar_Value + + begin + if Scal_Typ in Float_Scalar_Id then + return Invalid_Float_Value; + + else pragma Assert (Scal_Typ in Integer_Scalar_Id); + return Invalid_Integer_Value; + end if; + end Invalid_Scalar_Value; + ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- @@ -18771,6 +18965,70 @@ package body Sem_Util is end if; end Needs_One_Actual; + --------------------------------- + -- Needs_Simple_Initialization -- + --------------------------------- + + function Needs_Simple_Initialization + (Typ : Entity_Id; + Consider_IS : Boolean := True) return Boolean + is + Consider_IS_NS : constant Boolean := + Normalize_Scalars or (Initialize_Scalars and Consider_IS); + + begin + -- Never need initialization if it is suppressed + + if Initialization_Suppressed (Typ) then + return False; + end if; + + -- Check for private type, in which case test applies to the underlying + -- type of the private type. + + if Is_Private_Type (Typ) then + declare + RT : constant Entity_Id := Underlying_Type (Typ); + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + + -- Scalar type with Default_Value aspect requires initialization + + elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then + return True; + + -- Cases needing simple initialization are access types, and, if pragma + -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar + -- types. + + elsif Is_Access_Type (Typ) + or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) + then + return True; + + -- If Initialize/Normalize_Scalars is in effect, string objects also + -- need initialization, unless they are created in the course of + -- expanding an aggregate (since in the latter case they will be + -- filled with appropriate initializing values before they are used). + + elsif Consider_IS_NS + and then Is_Standard_String_Type (Typ) + and then + (not Is_Itype (Typ) + or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate) + then + return True; + + else + return False; + end if; + end Needs_Simple_Initialization; + ------------------------ -- New_Copy_List_Tree -- ------------------------ @@ -23782,6 +24040,40 @@ package body Sem_Util is Set_Entity (N, Val); end Set_Entity_With_Checks; + ------------------------------ + -- Set_Invalid_Scalar_Value -- + ------------------------------ + + procedure Set_Invalid_Scalar_Value + (Scal_Typ : Float_Scalar_Id; + Value : Ureal) + is + Slot : Ureal renames Invalid_Floats (Scal_Typ); + + begin + -- Detect an attempt to set a different value for the same scalar type + + pragma Assert (Slot = No_Ureal); + Slot := Value; + end Set_Invalid_Scalar_Value; + + ------------------------------ + -- Set_Invalid_Scalar_Value -- + ------------------------------ + + procedure Set_Invalid_Scalar_Value + (Scal_Typ : Integer_Scalar_Id; + Value : Uint) + is + Slot : Uint renames Invalid_Integers (Scal_Typ); + + begin + -- Detect an attempt to set a different value for the same scalar type + + pragma Assert (Slot = No_Uint); + Slot := Value; + end Set_Invalid_Scalar_Value; + ------------------------ -- Set_Name_Entity_Id -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0283ad7a2dd..4fa49dbcf2f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1325,6 +1325,9 @@ package Sem_Util is function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean; -- Return whether an array type has static bounds + function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean; + -- Determine whether array type Typ has static non-empty bounds + function Has_Stream (T : Entity_Id) return Boolean; -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the -- case of a composite type, has a component for which this predicate is @@ -1471,6 +1474,13 @@ package Sem_Util is procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id); -- Establish the SPARK_Mode and SPARK_Mode_Pragma currently in effect + function Invalid_Scalar_Value + (Loc : Source_Ptr; + Scal_Typ : Scalar_Id) return Node_Id; + -- Obtain the invalid value for scalar type Scal_Typ as either specified by + -- pragma Initialize_Scalars or by the binder. Return an expression created + -- at source location Loc, which denotes the invalid value. + function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call @@ -2183,6 +2193,19 @@ package Sem_Util is -- syntactic ambiguity that results from an indexing of a function call -- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y). + function Needs_Simple_Initialization + (Typ : Entity_Id; + Consider_IS : Boolean := True) return Boolean; + -- Certain types need initialization even though there is no specific + -- initialization routine: + -- Access types (which need initializing to null) + -- All scalar types if Normalize_Scalars mode set + -- Descendants of standard string types if Normalize_Scalars mode set + -- Scalar types having a Default_Value attribute + -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is + -- set to False, but if Consider_IS is set to True, then the cases above + -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode. + function New_Copy_List_Tree (List : List_Id) return List_Id; -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined -- below. As for New_Copy_Tree, it is illegal to attempt to copy extended @@ -2633,6 +2656,18 @@ package Sem_Util is -- If restriction No_Implementation_Identifiers is set, then it checks -- that the entity is not implementation defined. + procedure Set_Invalid_Scalar_Value + (Scal_Typ : Float_Scalar_Id; + Value : Ureal); + -- Associate invalid value Value with scalar type Scal_Typ as specified by + -- pragma Initialize_Scalars. + + procedure Set_Invalid_Scalar_Value + (Scal_Typ : Integer_Scalar_Id; + Value : Uint); + -- Associate invalid value Value with scalar type Scal_Typ as specified by + -- pragma Initialize_Scalars. + procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); pragma Inline (Set_Name_Entity_Id); -- Sets the Entity_Id value associated with the given name, which is the diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 73d96e67dc0..25d6fca6a8d 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1137,6 +1137,30 @@ package Snames is Name_Sequential : constant Name_Id := N + $; Last_Partition_Elaboration_Policy_Name : constant Name_Id := N + $; + -- Names of recognized scalar families for pragma Initialize_Scalars + + Name_Short_Float : constant Name_Id := N + $; -- GNAT + Name_Float : constant Name_Id := N + $; -- GNAT + Name_Long_Float : constant Name_Id := N + $; -- GNAT + Name_Long_Long_Float : constant Name_Id := N + $; -- GNAT + Name_Signed_8 : constant Name_Id := N + $; -- GNAT + Name_Signed_16 : constant Name_Id := N + $; -- GNAT + Name_Signed_32 : constant Name_Id := N + $; -- GNAT + Name_Signed_64 : constant Name_Id := N + $; -- GNAT + Name_Unsigned_8 : constant Name_Id := N + $; -- GNAT + Name_Unsigned_16 : constant Name_Id := N + $; -- GNAT + Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT + Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT + + subtype Scalar_Id is Name_Id range + Name_Short_Float .. Name_Unsigned_64; + + subtype Float_Scalar_Id is Name_Id range + Name_Short_Float .. Name_Long_Long_Float; + + subtype Integer_Scalar_Id is Name_Id range + Name_Signed_8 .. Name_Unsigned_64; + -- Names of recognized checks for pragma Suppress -- Note: the name Atomic_Synchronization can only be specified internally -- 2.30.2