+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
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;
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;
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");
--------------------------
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
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;
-- d.6
-- d.7
-- d.8
- -- d.9 Enable validation of pragma Compile_Time_[Error/Warning]
+ -- d.9
-- Debug flags for binder (GNATBIND)
-- 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 --
-- 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);
-- 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).
-- --
-- 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- --
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 (
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
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.
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.
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.
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.
-------------------------------------------
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;
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;
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
-
end Reallocate;
-------------
-------------
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;
-- --
-- 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- --
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
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
projects / gcc.git / commitdiff