Skip to content

R
riscv-gcc-1
Commit ec225529 by Arnaud Charlet
Options

[multiple changes] 

2016-10-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <gingold@adacore.com>

	* exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately
	on restricted profile.

2016-10-13  Javier Miranda  <miranda@adacore.com>

	* 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
parent 62c1b965
Showing with 177 additions and 46 deletions
gcc/ada/ChangeLog
2016-10-13 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <gingold@adacore.com>
* exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately
on restricted profile.
2016-10-13 Javier Miranda <miranda@adacore.com>
* 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 <kirtchev@adacore.com>
* sem_ch6.adb (Create_Extra_Formals): Generate
an Itype reference for the object extra formal in case the
subprogram is called within the same or nested scope.
......
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;
......
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");
--------------------------
......
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;
......
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 --
......
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);
......
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).
......
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 (
......
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.
......
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;
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;
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment