From: Arnaud Charlet Date: Wed, 6 Sep 2017 10:01:58 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9fb1e654f463fe3e30dccee2b6622c95edcf5d25;p=gcc.git [multiple changes] 2017-09-06 Yannick Moy * treepr.adb (Print_Entity_Info): Do not print empty Elist. 2017-09-06 Yannick Moy * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not consider calls to subprograms in other units as possibly inlined. 2017-09-06 Ed Schonberg * freeze.adb (Freeze_Entity): For a derived type that has no explicit delayed aspects but may inherit delayed aspects from its parent type, analyze aspect at freeze point for proper capture of an inherited aspect. 2017-09-06 Arnaud Charlet * lib-xref.adb (Get_Through_Renamings): Get through subprogram renamings; also, avoid repeated calls to Renamed_Object when getting through object renamings. 2017-09-06 Ed Schonberg * sem_ch3.adb (Array_Type_Declaration): Handle properly an array type declaration in a private part, when an index is a subtype indication of a discrete type with a private partial view. 2017-09-06 Javier Miranda * exp_ch4.adb (Expand_Modular_Op): Force generating temporary to improve the generated code. 2017-09-06 Tristan Gingold * s-fatgen.adb: Minor typo fix in comment. 2017-09-06 Ed Schonberg * exp_ch5.adb (Make_Field_Assign): If the type of the right-hand side has stored constraint, use its values (except for those that are renamings of parent discriminants) to produce additional assignments for the discriminants of the left-hand side, which are invisible in the righ-hand side and not retrievable as selected components. 2017-09-06 Ed Schonberg * sem_util.adb (Needs_One_Formal): The first formal of such a function must be a controlling formal, so that Obj.F (X, Y) can have the interpretation F(Obj)(X, Y). * sem_util.ads: Clarify documentation. 2017-09-06 Eric Botcazou * table.ads, table.adb: Restore original implementation. * namet.h (Names_Ptr): Adjust back. (Name_Chars_Ptr): Likewise. * uintp.h (Uints_Ptr): Likewise. (Udigits_Ptr): Likewise. * g-table.ads: Remove pragma Compiler_Unit_Warning. * par_sco.adb: Do not with GNAT.Table and use Table consistently. * scos.ads: Replace GNAT.Table with Table and adjust instantiations. * spark_xrefs.ads: Likewise. * scos.h: Undo latest changes. 2017-09-06 Ed Schonberg * sem_ch12.adb (Analyze_Subprogram_Instantiation): Propagate No_Return flag to instance if pragma applies to generic unit. This must be done explicitly because the pragma does not appear directly in the generic declaration (unlike the corresponding aspect specification). From-SVN: r251765 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d91c4b36784..5c0b3d7a25a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,77 @@ +2017-09-06 Yannick Moy + + * treepr.adb (Print_Entity_Info): Do not print empty Elist. + +2017-09-06 Yannick Moy + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not consider calls + to subprograms in other units as possibly inlined. + +2017-09-06 Ed Schonberg + + * freeze.adb (Freeze_Entity): For a derived type that has no + explicit delayed aspects but may inherit delayed aspects from its + parent type, analyze aspect at freeze point for proper capture + of an inherited aspect. + +2017-09-06 Arnaud Charlet + + * lib-xref.adb (Get_Through_Renamings): Get through subprogram + renamings; also, avoid repeated calls to Renamed_Object when getting + through object renamings. + +2017-09-06 Ed Schonberg + + * sem_ch3.adb (Array_Type_Declaration): Handle properly an + array type declaration in a private part, when an index is a + subtype indication of a discrete type with a private partial view. + +2017-09-06 Javier Miranda + + * exp_ch4.adb (Expand_Modular_Op): Force generating + temporary to improve the generated code. + +2017-09-06 Tristan Gingold + + * s-fatgen.adb: Minor typo fix in comment. + +2017-09-06 Ed Schonberg + + * exp_ch5.adb (Make_Field_Assign): If the type + of the right-hand side has stored constraint, use its values + (except for those that are renamings of parent discriminants) + to produce additional assignments for the discriminants of the + left-hand side, which are invisible in the righ-hand side and + not retrievable as selected components. + +2017-09-06 Ed Schonberg + + * sem_util.adb (Needs_One_Formal): The first formal of such a + function must be a controlling formal, so that Obj.F (X, Y) + can have the interpretation F(Obj)(X, Y). + * sem_util.ads: Clarify documentation. + +2017-09-06 Eric Botcazou + + * table.ads, table.adb: Restore original implementation. + * namet.h (Names_Ptr): Adjust back. + (Name_Chars_Ptr): Likewise. + * uintp.h (Uints_Ptr): Likewise. + (Udigits_Ptr): Likewise. + * g-table.ads: Remove pragma Compiler_Unit_Warning. + * par_sco.adb: Do not with GNAT.Table and use Table consistently. + * scos.ads: Replace GNAT.Table with Table and adjust instantiations. + * spark_xrefs.ads: Likewise. + * scos.h: Undo latest changes. + +2017-09-06 Ed Schonberg + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Propagate + No_Return flag to instance if pragma applies to generic unit. This + must be done explicitly because the pragma does not appear + directly in the generic declaration (unlike the corresponding + aspect specification). + 2017-09-06 Eric Botcazou * sem_ch7.adb (Has_Referencer): Move up and expand comment diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7f64cde371d..9e18ec78e3d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4069,6 +4069,31 @@ package body Exp_Ch4 is Set_Right_Opnd (Op_Expr, Unchecked_Convert_To (Standard_Integer, New_Copy_Tree (Right_Opnd (N)))); + + -- Link this node to the tree to analyze it + + -- If the parent node is an expression with actions we link it + -- to N since otherwise Force_Evaluation cannot identify if this + -- node comes from the Expression and rejects generating the + -- temporary. + + if Nkind (Parent (N)) = N_Expression_With_Actions then + Set_Parent (Op_Expr, N); + + -- Common case + + else + Set_Parent (Op_Expr, Parent (N)); + end if; + + Analyze (Op_Expr); + + -- Force generating a temporary because in the expansion of this + -- expression we may generate code that performs this computation + -- several times. + + Force_Evaluation (Op_Expr, Mode => Strict); + Set_Left_Opnd (Mod_Expr, Op_Expr); end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 59af6ab172b..4a892556356 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1590,6 +1590,48 @@ package body Exp_Ch5 is Next_Discriminant (F); end; end loop; + + -- If the derived type has a stored constraint, assign the value + -- of the corresponding discriminants explicitly, skipping those + -- that are renamed discriminants. We cannot just retrieve them + -- from the Rhs by selected component because they are invisible + -- in the type of the right-hand side. + + if Stored_Constraint (R_Typ) /= No_Elist then + declare + Discr_Val : Elmt_Id; + Assign : Node_Id; + + begin + Discr_Val := First_Elmt (Stored_Constraint (R_Typ)); + F := First_Entity (R_Typ); + while Present (F) loop + if Ekind (F) = E_Discriminant + and then Is_Completely_Hidden (F) + and then Present (Corresponding_Record_Component (F)) + and then (not Is_Entity_Name (Node (Discr_Val)) + or else Ekind (Entity (Node (Discr_Val))) + /= E_Discriminant) + then + Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + New_Occurrence_Of + (Corresponding_Record_Component (F), Loc)), + Expression => New_Copy (Node ((Discr_Val)))); + + Set_Assignment_OK (Name (Assign)); + Insert_Action (N, Assign); + Next_Elmt (Discr_Val); + end if; + + Next_Entity (F); + end loop; + end; + end if; end if; -- We know the underlying type is a record, but its current view diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 578563a800d..4d8aa656a57 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5266,8 +5266,12 @@ package body Freeze is -- pragma or attribute definition clause in the tree at this point. We -- also analyze the aspect specification node at the freeze point when -- the aspect doesn't correspond to pragma/attribute definition clause. + -- In addition, a derived type may have inherited aspects that were + -- delayed in the parent, so these must also be captured now. - if Has_Delayed_Aspects (E) then + if Has_Delayed_Aspects (E) + or else May_Inherit_Delayed_Rep_Aspects (E) + then Analyze_Aspects_At_Freeze_Point (E); end if; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads index ab5381353c3..ccda39bd91a 100644 --- a/gcc/ada/g-table.ads +++ b/gcc/ada/g-table.ads @@ -41,8 +41,6 @@ -- GNAT.Table -- Table (the compiler unit) -pragma Compiler_Unit_Warning; - with GNAT.Dynamic_Tables; generic diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 9f2539a6b62..007d59c9fda 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1349,6 +1349,15 @@ package body Inline is elsif In_Package_Visible_Spec (Id) then return False; + -- Do not inline subprograms declared in other units. This is important + -- in particular for subprograms defined in the private part of a + -- package spec, when analyzing one of its child packages, as otherwise + -- we issue spurious messages about the impossibility to inline such + -- calls. + + elsif not In_Extended_Main_Code_Unit (Id) then + return False; + -- Do not inline subprograms marked No_Return, possibly used for -- signaling errors, which GNATprove handles specially. diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index bcb1b6cfcad..d40f0d42fbd 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -413,17 +413,57 @@ package body Lib.Xref is --------------------------- function Get_Through_Renamings (E : Entity_Id) return Entity_Id is - Result : Entity_Id := E; - begin - while Present (Result) - and then Is_Object (Result) - and then Present (Renamed_Object (Result)) - loop - Result := Get_Enclosing_Object (Renamed_Object (Result)); - end loop; + case Ekind (E) is + -- For subprograms we just need to check once if they are have a + -- Renamed_Entity, because Renamed_Entity is set transitively. + + when Subprogram_Kind => + declare + Renamed : constant Entity_Id := Renamed_Entity (E); + + begin + if Present (Renamed) then + return Renamed; + else + return E; + end if; + end; + + -- For objects we need to repeatedly call Renamed_Object, because + -- it is not transitive. + + when Object_Kind => + declare + Obj : Entity_Id := E; + + begin + loop + pragma Assert (Present (Obj)); + + declare + Renamed : constant Entity_Id := Renamed_Object (Obj); + begin + if Present (Renamed) then + Obj := Get_Enclosing_Object (Renamed); + + -- The renamed expression denotes a non-object, + -- e.g. function call, slicing of a function call, + -- pointer dereference, etc. + if No (Obj) then + return Empty; + end if; + else + return Obj; + end if; + end; + end loop; + end; + + when others => + return E; - return Result; + end case; end Get_Through_Renamings; --------------- diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 84255a807fa..35068d388fc 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -45,11 +45,11 @@ struct Name_Entry }; /* Pointer to names table vector. */ -#define Names_Ptr namet__name_entries__tab__the_instance +#define Names_Ptr namet__name_entries__table extern struct Name_Entry *Names_Ptr; /* Pointer to name characters table. */ -#define Name_Chars_Ptr namet__name_chars__tab__the_instance +#define Name_Chars_Ptr namet__name_chars__table extern char *Name_Chars_Ptr; /* This is Hostparm.Max_Line_Length. */ diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index b3abb6dfbc6..d44b656530d 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -44,7 +44,6 @@ with Table; with GNAT.HTable; use GNAT.HTable; with GNAT.Heap_Sort_G; -with GNAT.Table; package body Par_SCO is @@ -76,12 +75,13 @@ package body Par_SCO is -- running some steps multiple times (the second pass has to be started -- from multiple places). - package SCO_Raw_Table is new GNAT.Table + package SCO_Raw_Table is new Table.Table (Table_Component_Type => SCO_Table_Entry, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 500, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Raw_Table"); ----------------------- -- Unit Number Table -- diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index c2185e07328..fdb34f2e885 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -726,11 +726,11 @@ package body System.Fat_Gen is -- This works provided that the intermediate result (RM1 + N) does not -- have extra precision (which is why we call Machine). When we compute -- RM1 + N, the exponent of N will be normalized and the mantissa shifted - -- shifted appropriately so the lower order bits, which cannot contribute - -- to the integer part of N, fall off on the right. When we subtract RM1 - -- again, the significant bits of N are shifted to the left, and what we - -- have is an integer, because only the first e bits are different from - -- zero (assuming binary radix here). + -- appropriately so the lower order bits, which cannot contribute to the + -- integer part of N, fall off on the right. When we subtract RM1 again, + -- the significant bits of N are shifted to the left, and what we have is + -- an integer, because only the first e bits are different from zero + -- (assuming binary radix here). function Truncation (X : T) return T is Result : T; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 412a45b2583..e99ace680a9 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2017, 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- -- @@ -29,10 +29,9 @@ -- is used in the ALI file. with Namet; use Namet; +with Table; with Types; use Types; -with GNAT.Table; - package SCOs is -- SCO information can exist in one of two forms. In the ALI file, it is @@ -383,12 +382,13 @@ package SCOs is -- For the SCO for a pragma/aspect, gives the pragma/apsect name end record; - package SCO_Table is new GNAT.Table ( + package SCO_Table is new Table.Table ( Table_Component_Type => SCO_Table_Entry, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 500, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Table"); Is_Decision : constant array (Character) of Boolean := ('E' | 'G' | 'I' | 'P' | 'a' | 'A' | 'W' | 'X' => True, @@ -530,12 +530,13 @@ package SCOs is end record; - package SCO_Unit_Table is new GNAT.Table ( + package SCO_Unit_Table is new Table.Table ( Table_Component_Type => SCO_Unit_Table_Entry, Table_Index_Type => SCO_Unit_Index, Table_Low_Bound => 0, -- see note above on sorting Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "Unit_Table"); ----------------------- -- Generic instances -- @@ -551,12 +552,13 @@ package SCOs is Enclosing_Instance : SCO_Instance_Index; end record; - package SCO_Instance_Table is new GNAT.Table ( + package SCO_Instance_Table is new Table.Table ( Table_Component_Type => SCO_Instance_Table_Entry, Table_Index_Type => SCO_Instance_Index, Table_Low_Bound => 1, Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "Instance_Table"); ----------------- -- Subprograms -- diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h index 4fb396ca630..bda373b60a5 100644 --- a/gcc/ada/scos.h +++ b/gcc/ada/scos.h @@ -45,16 +45,14 @@ struct SCO_Unit_Table_Entry typedef struct SCO_Unit_Table_Entry *SCO_Unit_Table_Type; -/* The following depends on the fact that The_Instance.Table - is the first component. */ -extern SCO_Unit_Table_Type scos__sco_unit_table__the_instance; -#define SCO_Unit_Table scos__sco_unit_table__the_instance +extern SCO_Unit_Table_Type scos__sco_unit_table__table; +#define SCO_Unit_Table scos__sco_unit_table__table -extern Int scos__sco_unit_table__first(void); -#define SCO_Unit_Table_First scos__sco_unit_table__first +extern Int scos__sco_unit_table__min; +#define SCO_Unit_Table_Min scos__sco_unit_table__min -extern Int scos__sco_unit_table__last(void); -#define SCO_Unit_Table_Last scos__sco_unit_table__last +extern Int scos__sco_unit_table__last_val; +#define SCO_Unit_Table_Last_Val scos__sco_unit_table__last_val /* SCOs table: */ @@ -76,16 +74,14 @@ struct SCO_Table_Entry typedef struct SCO_Table_Entry *SCO_Table_Type; -/* The following depends on the fact that The_Instance.Table - is the first component. */ -extern SCO_Table_Type scos__sco_table__the_instance; -#define SCO_Table scos__sco_table__the_instance +extern SCO_Table_Type scos__sco_table__table; +#define SCO_Table scos__sco_table__table -extern Int scos__sco_table__first(void); -#define SCO_Table_First scos__sco_table__first +extern Int scos__sco_table__min; +#define SCO_Table_Min scos__sco_table__min -extern Int scos__sco_table__last(void); -#define SCO_Table_Last scos__sco_table__last +extern Int scos__sco_table__last_val; +#define SCO_Table_Last_Val scos__sco_table__last_val #ifdef __cplusplus } diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2b1e1ba5583..acc293d5ef0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5382,6 +5382,15 @@ package body Sem_Ch12 is Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + -- Propagate No_Return if pragma applied to generic unit. This must + -- be done explicitly because pragma does not appear in generic + -- declaration (unlike the aspect case). + + if No_Return (Gen_Unit) then + Set_No_Return (Act_Decl_Id); + Set_No_Return (Anon_Id); + end if; + Set_Has_Pragma_Inline_Always (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); Set_Has_Pragma_Inline_Always diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7929f0256bd..b5fb5f954bb 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6000,8 +6000,8 @@ package body Sem_Ch3 is Analyze (Decl); Set_Etype (Index, New_E); - -- If the index is a range the Entity attribute is not - -- available. Example: + -- If the index is a range or a subtype indication it carries + -- no entity. Example: -- package Pkg is -- type T is private; @@ -6010,7 +6010,9 @@ package body Sem_Ch3 is -- Table : array (T(1) .. T(10)) of Boolean; -- end Pkg; - if Nkind (Index) /= N_Range then + -- Otherwise the type of the reference is its entity. + + if Is_Entity_Name (Index) then Set_Entity (Index, New_E); end if; end; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a0fcc41be37..dde75ce39e8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17050,6 +17050,7 @@ package body Sem_Util is if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) and then No (Default_Value (First_Formal (E))) + and then Is_Controlling_Formal (First_Formal (E)) then Formal := Next_Formal (First_Formal (E)); while Present (Formal) loop diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8f0520a3298..8eb71d0db74 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2012,9 +2012,10 @@ package Sem_Util is -- entity E. If no such instance exits, return Empty. function Needs_One_Actual (E : Entity_Id) return Boolean; - -- Returns True if a function has defaults for all but its first - -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that - -- results from an indexing of a function call written in prefix form. + -- Returns True if a function has defaults for all but its first formal, + -- which is a controlling formal. Used in Ada 2005 mode to solve the + -- 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 New_Copy_List_Tree (List : List_Id) return List_Id; -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index 52c0ef69478..fd5b76d4a66 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2017, 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- -- @@ -29,8 +29,8 @@ -- file, and by Get_SPARK_Xrefs/Put_SPARK_Xrefs to read/write the textual -- representation that is stored in the ALI file. +with Table; with Types; use Types; -with GNAT.Table; package SPARK_Xrefs is @@ -258,12 +258,13 @@ package SPARK_Xrefs is -- Column number for the reference end record; - package SPARK_Xref_Table is new GNAT.Table ( + package SPARK_Xref_Table is new Table.Table ( Table_Component_Type => SPARK_Xref_Record, Table_Index_Type => Xref_Index, Table_Low_Bound => 1, Table_Initial => 2000, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Xref_Table"); ----------------- -- Scope Table -- @@ -323,12 +324,13 @@ package SPARK_Xrefs is -- Entity (subprogram or package) for the scope end record; - package SPARK_Scope_Table is new GNAT.Table ( + package SPARK_Scope_Table is new Table.Table ( Table_Component_Type => SPARK_Scope_Record, Table_Index_Type => Scope_Index, Table_Low_Bound => 1, Table_Initial => 200, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Scope_Table"); ---------------- -- File Table -- @@ -360,12 +362,13 @@ package SPARK_Xrefs is -- Ending index in Scope table for this unit end record; - package SPARK_File_Table is new GNAT.Table ( + package SPARK_File_Table is new Table.Table ( Table_Component_Type => SPARK_File_Record, Table_Index_Type => File_Index, Table_Low_Bound => 1, Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "File_Table"); --------------- -- Constants -- diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 5d4522b449a..ed6f1f79728 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -29,6 +29,9 @@ -- -- ------------------------------------------------------------------------------ +with Debug; use Debug; +with Opt; use Opt; +with Output; use Output; with System; use System; with Tree_IO; use Tree_IO; @@ -36,20 +39,370 @@ with System.Memory; use System.Memory; with Unchecked_Conversion; +pragma Elaborate_All (Output); + package body Table is package body Table is + Min : constant Int := Int (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Length : Int := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + function Tree_Get_Table_Address return Address; -- Return Null_Address if the table length is zero, -- Table (First)'Address if not. + pragma Warnings (Off); + -- Turn off warnings. The following unchecked conversions are only used + -- internally in this package, and cannot never result in any instances + -- of improperly aliased pointers for the client of the package. + + function To_Address is new Unchecked_Conversion (Table_Ptr, Address); + function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); + + pragma Warnings (On); + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Set_Item (Table_Index_Type (Last_Val + 1), New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + Free (To_Address (Table)); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : constant Int := Length; + + begin + Locked := False; + Last_Val := Min - 1; + Max := Min + (Table_Initial * Table_Factor) - 1; + Length := Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + New_Size : Memory.size_t; + New_Length : Long_Long_Integer; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + -- Make sure that we have at least the initial allocation. This + -- is needed in cases where a zero length table is written out. + + Length := Int'Max (Length, Table_Initial); + + -- Now increment table length until it is sufficiently large. Use + -- the increment value or 10, which ever is larger (the reason + -- for the use of 10 here is to ensure that the table does really + -- increase in size (which would not be the case for a table of + -- length 10 increased by 3% for instance). Do the intermediate + -- calculation in Long_Long_Integer to avoid overflow. + + while Max < Last_Val loop + New_Length := + Long_Long_Integer (Length) * + (100 + Long_Long_Integer (Table_Increment)) / 100; + Length := Int'Max (Int (New_Length), Length + 10); + Max := Min + Length - 1; + end loop; + + if Debug_Flag_D then + Write_Str ("--> Allocating new "); + Write_Str (Table_Name); + Write_Str (" table, size = "); + Write_Int (Max - Min + 1); + Write_Eol; + end if; + end if; + + -- Do the intermediate calculation in size_t to avoid signed overflow + + New_Size := + Memory.size_t (Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit); + + if Table = null then + Table := To_Pointer (Alloc (New_Size)); + + elsif New_Size > 0 then + Table := + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); + end if; + + if Length /= 0 and then Table = null then + Set_Standard_Error; + Write_Str ("available memory exhausted"); + Write_Eol; + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + Extra_Length : Int; + Size : Memory.size_t; + + begin + Length := Last_Val - Int (Table_Low_Bound) + 1; + Size := Memory.size_t (Length) * + (Table_Type'Component_Size / Storage_Unit); + + -- If the size of the table exceeds the release threshold then leave + -- space to store as many extra elements as 0.1% of the table length. + + if Release_Threshold > 0 + and then Size > Memory.size_t (Release_Threshold) + then + Extra_Length := Length / 1000; + Length := Length + Extra_Length; + Max := Int (Table_Low_Bound) + Length - 1; + + if Debug_Flag_D then + Write_Str ("--> Release_Threshold reached (length="); + Write_Int (Int (Size)); + Write_Str ("): leaving room space for "); + Write_Int (Extra_Length); + Write_Str (" components"); + Write_Eol; + end if; + else + Max := Last_Val; + end if; + + Reallocate; + end Release; + + ------------- + -- Restore -- + ------------- + + procedure Restore (T : Saved_Table) is + begin + Free (To_Address (Table)); + Last_Val := T.Last_Val; + Max := T.Max; + Table := T.Table; + Length := Max - Min + 1; + end Restore; + + ---------- + -- Save -- + ---------- + + function Save return Saved_Table is + Res : Saved_Table; + + begin + Res.Last_Val := Last_Val; + Res.Max := Max; + Res.Table := Table; + + Table := null; + Length := 0; + Init; + return Res; + end Save; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type) + is + -- If Item is a value within the current allocation, and we are going + -- to reallocate, then we must preserve an intermediate copy here + -- before calling Increment_Last. Otherwise, if Table_Component_Type + -- is passed by reference, we are going to end up copying from + -- storage that might have been deallocated from Increment_Last + -- calling Reallocate. + + subtype Allocated_Table_T is + Table_Type (Table'First .. Table_Index_Type (Max + 1)); + -- A constrained table subtype one element larger than the currently + -- allocated table. + + Allocated_Table_Address : constant System.Address := + Table.all'Address; + -- Used for address clause below (we can't use non-static expression + -- Table.all'Address directly in the clause because some older + -- versions of the compiler do not allow it). + + Allocated_Table : Allocated_Table_T; + pragma Import (Ada, Allocated_Table); + pragma Suppress (Range_Check, On => Allocated_Table); + for Allocated_Table'Address use Allocated_Table_Address; + -- Allocated_Table represents the currently allocated array, plus one + -- element (the supplementary element is used to have a convenient + -- way of computing the address just past the end of the current + -- allocation). Range checks are suppressed because this unit + -- uses direct calls to System.Memory for allocation, and this can + -- yield misaligned storage (and we cannot rely on the bootstrap + -- compiler supporting specifically disabling alignment checks, so we + -- need to suppress all range checks). It is safe to suppress this + -- check here because we know that a (possibly misaligned) object + -- of that type does actually exist at that address. + -- ??? We should really improve the allocation circuitry here to + -- guarantee proper alignment. + + Need_Realloc : constant Boolean := Int (Index) > Max; + -- True if this operation requires storage reallocation (which may + -- involve moving table contents around). + + begin + -- If we're going to reallocate, check whether Item references an + -- element of the currently allocated table. + + if Need_Realloc + and then Allocated_Table'Address <= Item'Address + and then Item'Address < + Allocated_Table (Table_Index_Type (Max + 1))'Address + then + -- If so, save a copy on the stack because Increment_Last will + -- reallocate storage and might deallocate the current table. + + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (Index); + Table (Index) := Item_Copy; + end; + + else + -- Here we know that either we won't reallocate (case of Index < + -- Max) or that Item is not in the currently allocated table. + + if Int (Index) > Last_Val then + Set_Last (Index); + end if; + + Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Int (New_Val) < Last_Val then + Last_Val := Int (New_Val); + + else + Last_Val := Int (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + ---------------------------- -- Tree_Get_Table_Address -- ---------------------------- function Tree_Get_Table_Address return Address is begin - if Is_Empty then + if Length = 0 then return Null_Address; else return Table (First)'Address; @@ -65,15 +418,15 @@ package body Table is -- does an implicit Release. procedure Tree_Read is - Last : Int; begin - Init; - Tree_Read_Int (Last); - Set_Last (Table_Last_Type (Last)); + Tree_Read_Int (Max); + Last_Val := Max; + Length := Max - Min + 1; + Reallocate; Tree_Read_Data (Tree_Get_Table_Address, - (Last - Int (First) + 1) * + (Last_Val - Int (First) + 1) * -- Note the importance of parenthesizing the following division -- to avoid the possibility of intermediate overflow. @@ -93,9 +446,11 @@ package body Table is Tree_Write_Int (Int (Last)); Tree_Write_Data (Tree_Get_Table_Address, - (Int (Last - First) + 1) * + (Last_Val - Int (First) + 1) * (Table_Type'Component_Size / Storage_Unit)); end Tree_Write; + begin + Init; end Table; end Table; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 8782f116d51..dcfc6fb6920 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -29,20 +29,19 @@ -- -- ------------------------------------------------------------------------------ --- This package is a wrapper for GNAT.Table, for use in the compiler front --- end. It adds the Tree_Write/Tree_Read functionality; everything else is --- just a renaming of GNAT.Table. See GNAT.Table (g-table.ads) and --- GNAT.Dynamic_Tables (g-dyntab.ads) for documentation. - --- Note that these three interfaces should remain synchronized to keep as much --- coherency as possible among these related units: --- --- GNAT.Dynamic_Tables --- GNAT.Table --- Table (the compiler unit) +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package uses a very efficient memory management scheme and any +-- change must be carefully evaluated on compilation of real software. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these +-- three related units. with Types; use Types; -with GNAT.Table; package Table is pragma Elaborate_Body; @@ -51,66 +50,199 @@ package Table is type Table_Component_Type is private; type Table_Index_Type is range <>; - Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; - Table_Initial : Pos := 8; - Table_Increment : Nat := 100; - Table_Name : String; -- for debugging printouts + Table_Low_Bound : Table_Index_Type; + Table_Initial : Pos; + Table_Increment : Nat; + Table_Name : String; Release_Threshold : Nat := 0; package Table is - package Tab is new GNAT.Table - (Table_Component_Type, - Table_Index_Type, - Table_Low_Bound, - Positive (Table_Initial), - Natural (Table_Increment), - Table_Name, - Natural (Release_Threshold)); - - subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type; - subtype Table_Last_Type is Tab.Table_Last_Type; - subtype Table_Type is Tab.Table_Type; - - subtype Table_Ptr is Tab.Table_Ptr; - - Table : Table_Ptr renames Tab.Table; - - Locked : Boolean renames Tab.Locked; - - function Is_Empty return Boolean renames Tab.Is_Empty; - - procedure Init renames Tab.Init; - - function First return Table_Index_Type renames Tab.First; - function Last return Table_Last_Type renames Tab.Last; + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be + -- an integer type. The effect is roughly to declare: + + -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) + -- of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. The value used is Opt.Table_Factor * Table_Initial. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Table_Name parameter is simply use in debug output messages it + -- has no other usage, and is not referenced in non-debugging mode. + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: We do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + -- WARNING: On HPPA, the virtual addressing approach used in this unit + -- is incompatible with the indexing instructions on the HPPA. So when + -- using this unit, compile your application with -mdisable-indexing. + + -- WARNING: If the table is reallocated, then the address of all its + -- components will change. So do not capture the address of an element + -- and then use the address later after the table may be reallocated. + -- One tricky case of this is passing an element of the table to a + -- subprogram by reference where the table gets reallocated during + -- the execution of the subprogram. The best rule to follow is never + -- to pass a table element as a parameter except for the case of IN + -- mode parameters with scalar values. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. + + type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; + -- The table is actually represented as a pointer to allow reallocation + + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the range + -- First .. Last. + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. This + -- feature is used to control table expansion during Gigi processing. + -- Gigi assumes that tables other than the Uint and Ureal tables do + -- not move during processing, which means that they cannot be expanded. + -- The Locked flag is used to enforce this restriction. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which + -- can then be used as a subscript for Table. Note that the only way to + -- modify Last is to call the Set_Last procedure. Last must always be + -- used to determine the logically last entry. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. If Release_Threshold is 0 or the + -- length of the table does not exceed this threshold then a call to + -- Release releases all storage that is allocated, but is not logically + -- part of the current array value; otherwise the call to Release leaves + -- the current array value plus 0.1% of the current table length free + -- elements located at the end of the table (this parameter facilitates + -- reopening large tables and adding a few elements without allocating a + -- chunk of memory). In both cases current array values are not affected + -- by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accommodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed + -- from the table. If Set_Last increases the size of the table, then + -- new entries are logically added to the table. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1) + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1) + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Append_All (New_Vals : Table_Type); + -- Appends all components of New_Vals - procedure Release renames Tab.Release; - - procedure Free renames Tab.Free; - - procedure Set_Last (New_Val : Table_Last_Type) renames Tab.Set_Last; - - procedure Increment_Last renames Tab.Increment_Last; - procedure Decrement_Last renames Tab.Decrement_Last; + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if + -- current table length is less than Index and in that case Last is set + -- to Index. Item will replace any value already present in the table + -- at this position. - procedure Append (New_Val : Table_Component_Type) renames Tab.Append; - procedure Append_All (New_Vals : Table_Type) renames Tab.Append_All; + type Saved_Table is private; + -- Type used for Save/Restore subprograms - procedure Set_Item - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type) renames Tab.Set_Item; + function Save return Saved_Table; + -- Resets table to empty, but saves old contents of table in returned + -- value, for possible later restoration by a call to Restore. - subtype Saved_Table is Tab.Saved_Table; - function Save return Saved_Table renames Tab.Save; - procedure Restore (T : in out Saved_Table) renames Tab.Restore; + procedure Restore (T : Saved_Table); + -- Given a Saved_Table value returned by a prior call to Save, restores + -- the table to the state it was in at the time of the Save call. procedure Tree_Write; -- Writes out contents of table using Tree_IO procedure Tree_Read; -- Initializes table by reading contents previously written with the - -- Tree_Write call, also using Tree_IO. + -- Tree_Write call (also using Tree_IO). + + private + + Last_Val : Int; + -- Current value of Last. Note that we declare this in the private part + -- because we don't want the client to modify Last except through one of + -- the official interfaces (since a modification to Last may require a + -- reallocation of the table). + + Max : Int; + -- Subscript of the maximum entry in the currently allocated table + + type Saved_Table is record + Last_Val : Int; + Max : Int; + Table : Table_Ptr; + end record; end Table; end Table; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 7c1f1b7d93e..6f25a7bd96a 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -423,12 +423,13 @@ package body Treepr is procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is function Field_Present (U : Union_Id) return Boolean; -- Returns False unless the value U represents a missing value - -- (Empty, No_Uint, No_Ureal or No_String) + -- (Empty, No_Elist, No_Uint, No_Ureal or No_String) function Field_Present (U : Union_Id) return Boolean is begin return U /= Union_Id (Empty) and then + U /= Union_Id (No_Elist) and then U /= To_Union (No_Uint) and then U /= To_Union (No_Ureal) and then U /= Union_Id (No_String); diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h index 5263b1ba822..ec374b3c8f9 100644 --- a/gcc/ada/uintp.h +++ b/gcc/ada/uintp.h @@ -101,11 +101,11 @@ extern Boolean UI_Lt (Uint, Uint); the integer value itself. The origin of the Uints_Ptr table is adjusted so that a Uint value of Uint_Bias indexes the first element. */ -#define Uints_Ptr (uintp__uints__tab__the_instance - Uint_Table_Start) -extern struct Uint_Entry *uintp__uints__tab__the_instance; +#define Uints_Ptr (uintp__uints__table - Uint_Table_Start) +extern struct Uint_Entry *uintp__uints__table; -#define Udigits_Ptr uintp__udigits__tab__the_instance -extern int *uintp__udigits__tab__the_instance; +#define Udigits_Ptr uintp__udigits__table +extern int *uintp__udigits__table; #ifdef __cplusplus }