From ec2255295c35008f5f39c9a79d5f342416ce6e86 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 13 Oct 2016 15:00:54 +0200 Subject: [PATCH] [multiple changes] 2016-10-13 Hristian Kirtchev * sem_ch6.adb (Analyze_Expression_Function): Remove the aspects of the original expression function has been rewritten into a subprogram declaration or a body. Reinsert the aspects once they have been analyzed. 2016-10-13 Tristan Gingold * exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately on restricted profile. 2016-10-13 Javier Miranda * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Register the pragma for its validation after the backend has been called only if its expression has some occurrence of attributes 'size or 'alignment * table.ads (Release_Threshold): New formal. (Release): Adding documentation of its new functionality. * table.adb (Release): Extend its functionality with a Release_Threshold. * nlists.adb (Next_Node table): Set its Release_Threshold. * atree.adb (Orig_Nodes table): Set its Release_Threshold. * atree.ads (Nodes table): Set its Release_Threshold. (Flags table): Set its Release_Threshold. * alloc.ads (Nodes_Release_Threshold): New constant declaration. (Orig_Nodes_Release_Threshold): New constant declaration. * debug.adb (switch d.9): Left free. * gnat1drv.adb (Post_Compilation_Validation_Checks): Enable validation of pragmas Compile_Time_Error and Compile_Time_Warning. From-SVN: r241117 --- gcc/ada/ChangeLog | 32 +++++++++++++++++++++++++++++ gcc/ada/alloc.ads | 2 ++ gcc/ada/atree.adb | 1 + gcc/ada/atree.ads | 2 ++ gcc/ada/debug.adb | 6 +----- gcc/ada/exp_ch9.adb | 7 +++++++ gcc/ada/gnat1drv.adb | 19 +++++++---------- gcc/ada/nlists.adb | 3 ++- gcc/ada/sem_ch6.adb | 49 +++++++++++++++++++++++++++++--------------- gcc/ada/sem_prag.adb | 49 +++++++++++++++++++++++++++++++++++++++++++- gcc/ada/table.adb | 30 +++++++++++++++++++++++++-- gcc/ada/table.ads | 23 +++++++++++++-------- 12 files changed, 177 insertions(+), 46 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 71014fb429b..b2c29fdd053 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2016-10-13 Hristian Kirtchev + + * sem_ch6.adb (Analyze_Expression_Function): + Remove the aspects of the original expression function has been + rewritten into a subprogram declaration or a body. Reinsert the + aspects once they have been analyzed. + +2016-10-13 Tristan Gingold + + * exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately + on restricted profile. + +2016-10-13 Javier Miranda + + * sem_prag.adb + (Process_Compile_Time_Warning_Or_Error): Register the pragma + for its validation after the backend has been called only if its + expression has some occurrence of attributes 'size or 'alignment + * table.ads (Release_Threshold): New formal. + (Release): Adding documentation of its new functionality. + * table.adb (Release): Extend its functionality with a + Release_Threshold. + * nlists.adb (Next_Node table): Set its Release_Threshold. + * atree.adb (Orig_Nodes table): Set its Release_Threshold. + * atree.ads (Nodes table): Set its Release_Threshold. + (Flags table): Set its Release_Threshold. + * alloc.ads (Nodes_Release_Threshold): New constant declaration. + (Orig_Nodes_Release_Threshold): New constant declaration. + * debug.adb (switch d.9): Left free. + * gnat1drv.adb (Post_Compilation_Validation_Checks): Enable + validation of pragmas Compile_Time_Error and Compile_Time_Warning. + 2016-10-13 Hristian Kirtchev * sem_ch6.adb (Create_Extra_Formals): Generate diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 4cdb1d23d26..7112fabfacf 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -102,6 +102,7 @@ package Alloc is Nodes_Initial : constant := 50_000; -- Atree Nodes_Increment : constant := 100; + Nodes_Release_Threshold : constant := 100_000; Notes_Initial : constant := 100; -- Lib Notes_Increment : constant := 200; @@ -111,6 +112,7 @@ package Alloc is Orig_Nodes_Initial : constant := 50_000; -- Atree Orig_Nodes_Increment : constant := 100; + Orig_Nodes_Release_Threshold : constant := 100_000; Pending_Instantiations_Initial : constant := 10; -- Inline Pending_Instantiations_Increment : constant := 100; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 87ef79fdeec..44188cfbba9 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -516,6 +516,7 @@ package body Atree is Table_Low_Bound => First_Node_Id, Table_Initial => Alloc.Orig_Nodes_Initial, Table_Increment => Alloc.Orig_Nodes_Increment, + Release_Threshold => Alloc.Orig_Nodes_Release_Threshold, Table_Name => "Orig_Nodes"); -------------------------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2d911b23b7f..bf4e52e4ef1 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -4206,6 +4206,7 @@ package Atree is Table_Low_Bound => First_Node_Id, Table_Initial => Alloc.Nodes_Initial, Table_Increment => Alloc.Nodes_Increment, + Release_Threshold => Alloc.Nodes_Release_Threshold, Table_Name => "Nodes"); -- The following is a parallel table to Nodes, which provides 8 more @@ -4251,6 +4252,7 @@ package Atree is Table_Low_Bound => First_Node_Id, Table_Initial => Alloc.Nodes_Initial, Table_Increment => Alloc.Nodes_Increment, + Release_Threshold => Alloc.Nodes_Release_Threshold, Table_Name => "Flags"); end Atree_Private_Part; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d9367375e7b..e3c53dda462 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -163,7 +163,7 @@ package body Debug is -- d.6 -- d.7 -- d.8 - -- d.9 Enable validation of pragma Compile_Time_[Error/Warning] + -- d.9 -- Debug flags for binder (GNATBIND) @@ -774,10 +774,6 @@ package body Debug is -- d.5 By default a subprogram imported generates a subprogram profile. -- This debug flag disables this generation when generating C code, -- assuming a proper #include will be used instead. - -- - -- d.9 Flag used temporarily to enable the validation of pragmas Compile_ - -- Time_Error and Compile_Time_Warning after the back end has been - -- called. ------------------------------------------ -- Documentation for Binder Debug Flags -- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 7109dcdf82b..dd812cc9e92 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -7176,6 +7176,13 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Asynchronous_Select begin + -- Asynchronous select is not supported on restricted runtimes. Don't + -- try to expand. + + if Restricted_Profile then + return; + end if; + Process_Statements_For_Controlled_Objects (Trig); Process_Statements_For_Controlled_Objects (Abrt); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 605bac59858..929bfcc316d 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -875,18 +875,13 @@ procedure Gnat1drv is -- and alignment annotated by the backend where possible). We need to -- unlock temporarily these tables to reanalyze their expression. - -- ??? temporarily disabled since it causes regressions with large - -- sources - - if Debug_Flag_Dot_9 then - Atree.Unlock; - Nlists.Unlock; - Sem.Unlock; - Sem_Ch13.Validate_Compile_Time_Warning_Errors; - Sem.Lock; - Nlists.Lock; - Atree.Lock; - end if; + Atree.Unlock; + Nlists.Unlock; + Sem.Unlock; + Sem_Ch13.Validate_Compile_Time_Warning_Errors; + Sem.Lock; + Nlists.Lock; + Atree.Lock; -- Validate unchecked conversions (using the values for size and -- alignment annotated by the backend where possible). diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index dcb5dd41cb7..b40446a3b46 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -90,6 +90,7 @@ package body Nlists is Table_Low_Bound => First_Node_Id, Table_Initial => Alloc.Orig_Nodes_Initial, Table_Increment => Alloc.Orig_Nodes_Increment, + Release_Threshold => Alloc.Orig_Nodes_Release_Threshold, Table_Name => "Next_Node"); package Prev_Node is new Table.Table ( diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 814d1183003..53ca284dc4d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -274,17 +274,17 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); - Def_Id : Entity_Id; + Asp : Node_Id; + Def_Id : Entity_Id; + New_Body : Node_Id; + New_Spec : Node_Id; + Orig_N : Node_Id; + Ret : Node_Id; Prev : Entity_Id; -- If the expression is a completion, Prev is the entity whose -- declaration is completed. Def_Id is needed to analyze the spec. - New_Body : Node_Id; - New_Spec : Node_Id; - Ret : Node_Id; - Asp : Node_Id; - begin -- This is one of the occasions on which we transform the tree during -- semantic analysis. If this is a completion, transform the expression @@ -392,12 +392,11 @@ package body Sem_Ch6 is Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True); Rewrite (N, New_Body); - -- Correct the parent pointer of the aspect specification list to - -- reference the rewritten node. + -- Remove any existing aspects from the original node because the act + -- of rewriting cases the list to be shared between the two nodes. - if Has_Aspects (N) then - Set_Parent (Aspect_Specifications (N), N); - end if; + Orig_N := Original_Node (N); + Remove_Aspects (Orig_N); -- Propagate any pragmas that apply to the expression function to the -- proper body when the expression function acts as a completion. @@ -406,6 +405,14 @@ package body Sem_Ch6 is Relocate_Pragmas_To_Body (N); Analyze (N); + -- Once the aspects of the generated body has been analyzed, create a + -- copy for ASIS purposes and assciate it with the original node. + + if Has_Aspects (N) then + Set_Aspect_Specifications (Orig_N, + New_Copy_List_Tree (Aspect_Specifications (N))); + end if; + -- Prev is the previous entity with the same name, but it is can -- be an unrelated spec that is not completed by the expression -- function. In that case the relevant entity is the one in the body. @@ -451,15 +458,21 @@ package body Sem_Ch6 is Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec)); - -- Correct the parent pointer of the aspect specification list to - -- reference the rewritten node. + -- Remove any existing aspects from the original node because the act + -- of rewriting cases the list to be shared between the two nodes. - if Has_Aspects (N) then - Set_Parent (Aspect_Specifications (N), N); - end if; + Orig_N := Original_Node (N); + Remove_Aspects (Orig_N); Analyze (N); - Def_Id := Defining_Entity (N); + + -- Once the aspects of the generated spec has been analyzed, create a + -- copy for ASIS purposes and assciate it with the original node. + + if Has_Aspects (N) then + Set_Aspect_Specifications (Orig_N, + New_Copy_List_Tree (Aspect_Specifications (N))); + end if; -- If aspect SPARK_Mode was specified on the body, it needs to be -- repeated both on the generated spec and the body. @@ -472,6 +485,8 @@ package body Sem_Ch6 is Set_Aspect_Specifications (New_Body, New_List (Asp)); end if; + Def_Id := Defining_Entity (N); + -- Within a generic pre-analyze the original expression for name -- capture. The body is also generated but plays no role in -- this because it is not part of the original source. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index e553dabaf8f..26a4870032e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7015,8 +7015,45 @@ package body Sem_Prag is ------------------------------------------- procedure Process_Compile_Time_Warning_Or_Error is + Validation_Needed : Boolean := False; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Tree visitor that checks if N is an attribute reference that can + -- be statically computed by the backend. Validation_Needed is set + -- to True if found. + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (N)) + then + declare + Attr_Id : constant Attribute_Id := + Get_Attribute_Id (Attribute_Name (N)); + begin + if Attr_Id = Attribute_Alignment + or else Attr_Id = Attribute_Size + then + Validation_Needed := True; + end if; + end; + end if; + + return OK; + end Check_Node; + + procedure Check_Expression is new Traverse_Proc (Check_Node); + + -- Local variables + Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); + -- Start of processing for Process_Compile_Time_Warning_Or_Error + begin Check_Arg_Count (2); Check_No_Identifiers; @@ -7025,8 +7062,18 @@ package body Sem_Prag is if Compile_Time_Known_Value (Arg1x) then Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1)); + + -- Register the expression for its validation after the backend has + -- been called if it has occurrences of attributes size or alignment + -- (because they may be statically computed by the backend and hence + -- the whole expression needs to be re-evaluated). + else - Sem_Ch13.Validate_Compile_Time_Warning_Error (N); + Check_Expression (Arg1x); + + if Validation_Needed then + Sem_Ch13.Validate_Compile_Time_Warning_Error (N); + end if; end if; end Process_Compile_Time_Warning_Or_Error; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 34fe7283787..2c7eb0c4a66 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -229,7 +229,6 @@ package body Table is Set_Standard_Output; raise Unrecoverable_Error; end if; - end Reallocate; ------------- @@ -237,9 +236,36 @@ package body Table is ------------- procedure Release is + Extra_Length : Int; + Size : Memory.size_t; + begin Length := Last_Val - Int (Table_Low_Bound) + 1; - Max := Last_Val; + 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; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 4788016738c..e928ef084ba 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -47,10 +47,11 @@ package Table is type Table_Component_Type is private; type Table_Index_Type is range <>; - Table_Low_Bound : Table_Index_Type; - Table_Initial : Pos; - Table_Increment : Nat; - Table_Name : String; + Table_Low_Bound : Table_Index_Type; + Table_Initial : Pos; + Table_Increment : Nat; + Table_Name : String; + Release_Threshold : Nat := 0; package Table is @@ -151,9 +152,15 @@ package Table is procedure Release; -- Storage is allocated in chunks according to the values given in the - -- Initial and Increment parameters. A call to Release releases all - -- storage that is allocated, but is not logically part of the current - -- array value. Current array values are not affected by this call. + -- 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 -- 2.30.2