Skip to content

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

[multiple changes] 

2011-09-02  Bob Duff  <duff@adacore.com>

	* einfo.adb: (Has_Xref_Entry): Do not call
	Implementation_Base_Type. Lib.Xref has been
	rewritten to avoid the need for it, and it was costly.
	* s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New
	functions in support of efficient xref.
	* lib-xref-alfa.adb: Misc changes related to Key component of
	type Xref_Entry.
	* lib-xref.adb: (Add_Entry,etc): Speed improvement.
	(New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry
	no longer does. This is the one place where it is needed.

2011-09-02  Johannes Kanig  <kanig@adacore.com>

	* g-comlin.adb (Getopt): New optional argument Concatenate to have
	similar interface as the other Getopt function.

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb: (Expand_Allocator_Expression): Do not generate
	a call to Set_Finalize_Address if there is no allocator available.
	* exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for
	a case of allocator expansion where the allocator is not expanded but
	needs a custom allocate routine. Code reformatting.
	(Is_Finalizable_Transient): Remove local variables Has_Rens and
	Ren_Obj. Code reformatting.
	(Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing
	through the use of 'reference.
	* sem_ch4.adb: (Analyze_Allocator): Detect allocators generated
	as part of build-in-place expansion. They are intentionally marked as
	coming from source, but their parents are not.

From-SVN: r178436
parent bd0bc43e
Showing with 237 additions and 113 deletions
gcc/ada/ChangeLog
2011-09-02 Bob Duff <duff@adacore.com>
* einfo.adb: (Has_Xref_Entry): Do not call
Implementation_Base_Type. Lib.Xref has been
rewritten to avoid the need for it, and it was costly.
* s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New
functions in support of efficient xref.
* lib-xref-alfa.adb: Misc changes related to Key component of
type Xref_Entry.
* lib-xref.adb: (Add_Entry,etc): Speed improvement.
(New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry
no longer does. This is the one place where it is needed.
2011-09-02 Johannes Kanig <kanig@adacore.com>
* g-comlin.adb (Getopt): New optional argument Concatenate to have
similar interface as the other Getopt function.
2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb: (Expand_Allocator_Expression): Do not generate
a call to Set_Finalize_Address if there is no allocator available.
* exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for
a case of allocator expansion where the allocator is not expanded but
needs a custom allocate routine. Code reformatting.
(Is_Finalizable_Transient): Remove local variables Has_Rens and
Ren_Obj. Code reformatting.
(Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing
through the use of 'reference.
* sem_ch4.adb: (Analyze_Allocator): Detect allocators generated
as part of build-in-place expansion. They are intentionally marked as
coming from source, but their parents are not.
2011-09-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Analyze_With_Clause): If the library unit
......
gcc/ada/einfo.adb
......@@ -1599,7 +1599,7 @@ package body Einfo is
function Has_Xref_Entry (Id : E) return B is
begin
return Flag182 (Implementation_Base_Type (Id));
return Flag182 (Id);
end Has_Xref_Entry;
function Hiding_Loop_Variable (Id : E) return E is
......
gcc/ada/exp_ch4.adb
......@@ -1137,11 +1137,14 @@ package body Exp_Ch4 is
-- Since .NET/JVM compilers do not support address arithmetic,
-- this call is skipped. The same is done for CodePeer because
-- primitive Finalize_Address is never generated.
-- primitive Finalize_Address is never generated. Do not create
-- this call if there is no allocator available any more.
if VM_Target = No_VM
and then not CodePeer_Mode
and then Present (Finalization_Master (PtrT))
and then Present (Temp_Decl)
and then Nkind (Expression (Temp_Decl)) = N_Allocator
then
Insert_Action (N,
Make_Set_Finalize_Address_Call
......
gcc/ada/exp_util.adb
......@@ -494,13 +494,39 @@ package body Exp_Util is
Expr := N;
end if;
Ptr_Typ := Base_Type (Etype (Expr));
-- In certain cases an allocator with a qualified expression may
-- be relocated and used as the initialization expression of a
-- temporary:
-- The allocator may have been rewritten into something else
-- before:
-- Obj : Ptr_Typ := new Desig_Typ'(...);
if Nkind (Expr) = N_Allocator then
Proc_To_Call := Procedure_To_Call (Expr);
-- after:
-- Tmp : Ptr_Typ := new Desig_Typ'(...);
-- Obj : Ptr_Typ := Tmp;
-- Since the allocator is always marked as analyzed to avoid infinite
-- expansion, it will never be processed by this routine given that
-- the designated type needs finalization actions. Detect this case
-- and complete the expansion of the allocator.
if Nkind (Expr) = N_Identifier
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
then
Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
return;
end if;
-- The allocator may have been rewritten into something else in which
-- case the expansion performed by this routine does not apply.
if Nkind (Expr) /= N_Allocator then
return;
end if;
Ptr_Typ := Base_Type (Etype (Expr));
Proc_To_Call := Procedure_To_Call (Expr);
end if;
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
......@@ -3726,8 +3752,6 @@ package body Exp_Util is
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Desig : Entity_Id := Obj_Typ;
Has_Rens : Boolean := True;
Ren_Obj : Entity_Id;
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is initialized either
......@@ -3741,14 +3765,15 @@ package body Exp_Util is
-- value 1 and BIPaccess is not null. This case creates an aliasing
-- between the returned value and the value denoted by BIPaccess.
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is allocated on the heap
function Is_Renamed
function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean;
-- Determine whether transient object Trans_Id has been renamed in the
-- statement list starting from First_Stmt.
-- Determine whether transient object Trans_Id has been renamed or
-- aliased through 'reference in the statement list starting from
-- First_Stmt.
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is allocated on the heap
---------------------------
-- Initialized_By_Access --
......@@ -3849,30 +3874,14 @@ package body Exp_Util is
return False;
end Initialized_By_Aliased_BIP_Func_Call;
------------------
-- Is_Allocated --
------------------
function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Expression (Parent (Trans_Id));
begin
return
Is_Access_Type (Etype (Trans_Id))
and then Present (Expr)
and then Nkind (Expr) = N_Allocator;
end Is_Allocated;
----------------
-- Is_Renamed --
-- Is_Aliased --
----------------
function Is_Renamed
function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean
is
Stmt : Node_Id;
function Extract_Renamed_Object
(Ren_Decl : Node_Id) return Entity_Id;
-- Given an object renaming declaration, retrieve the entity of the
......@@ -3918,25 +3927,29 @@ package body Exp_Util is
return Empty;
end Extract_Renamed_Object;
-- Start of processing for Is_Renamed
begin
-- If a previous invocation of this routine has determined that a
-- list has no renamings, then no point in repeating the same scan.
if not Has_Rens then
return False;
end if;
-- Local variables
-- Assume that the statement list does not have a renaming. This is a
-- minor optimization.
Expr : Node_Id;
Ren_Obj : Entity_Id;
Stmt : Node_Id;
Has_Rens := False;
-- Start of processing for Is_Aliased
begin
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Renaming_Declaration then
Has_Rens := True;
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr)
and then Nkind (Expr) = N_Reference
and then Nkind (Prefix (Expr)) = N_Identifier
and then Entity (Prefix (Expr)) = Trans_Id
then
return True;
end if;
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Extract_Renamed_Object (Stmt);
if Present (Ren_Obj)
......@@ -3950,7 +3963,21 @@ package body Exp_Util is
end loop;
return False;
end Is_Renamed;
end Is_Aliased;
------------------
-- Is_Allocated --
------------------
function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Expression (Parent (Trans_Id));
begin
return
Is_Access_Type (Etype (Trans_Id))
and then Present (Expr)
and then Nkind (Expr) = N_Allocator;
end Is_Allocated;
-- Start of processing for Is_Finalizable_Transient
......@@ -3967,6 +3994,11 @@ package body Exp_Util is
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
and then not Is_Aliased (Obj_Id, Decl)
-- Do not consider transient objects allocated on the heap since they
-- are attached to a finalization master.
......@@ -3985,11 +4017,6 @@ package body Exp_Util is
and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
-- Do not consider renamed transient objects because the act of
-- renaming extends the object's lifetime.
and then not Is_Renamed (Obj_Id, Decl)
-- Do not consider conversions of tags to class-wide types
and then not Is_Tag_To_CW_Conversion (Obj_Id);
......
gcc/ada/g-comlin.adb
......@@ -3238,7 +3238,8 @@ package body GNAT.Command_Line is
procedure Getopt
(Config : Command_Line_Configuration;
Callback : Switch_Handler := null;
Parser : Opt_Parser := Command_Line_Parser)
Parser : Opt_Parser := Command_Line_Parser;
Concatenate : Boolean := True)
is
Getopt_Switches : String_Access;
C : Character := ASCII.NUL;
......@@ -3373,7 +3374,7 @@ package body GNAT.Command_Line is
loop
C := Getopt (Switches => Getopt_Switches.all,
Concatenate => True,
Concatenate => Concatenate,
Parser => Parser);
if C = '*' then
......
gcc/ada/g-comlin.ads
......@@ -705,7 +705,8 @@ package GNAT.Command_Line is
procedure Getopt
(Config : Command_Line_Configuration;
Callback : Switch_Handler := null;
Parser : Opt_Parser := Command_Line_Parser);
Parser : Opt_Parser := Command_Line_Parser;
Concatenate : Boolean := True);
-- Similar to the standard Getopt function.
-- For each switch found on the command line, this calls Callback, if the
-- switch is not handled automatically.
......@@ -716,6 +717,9 @@ package GNAT.Command_Line is
-- variable). This function will in fact never call [Callback] if all
-- switches were handled automatically and there is nothing left to do.
--
-- The option Concatenate is identical to the one of the standard Getopt
-- function.
--
-- This procedure automatically adds -h and --help to the valid switches,
-- to display the help message and raises Exit_From_Command_Line.
-- If an invalid switch is specified on the command line, this procedure
......
gcc/ada/s-htable.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1995-2010, AdaCore --
-- Copyright (C) 1995-2011, AdaCore --
-- --
-- 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- --
......@@ -121,6 +121,15 @@ package body System.HTable is
return Iterator_Ptr;
end Get_Non_Null;
-------------
-- Present --
-------------
function Present (K : Key) return Boolean is
begin
return Get (K) /= Null_Ptr;
end Present;
------------
-- Remove --
------------
......@@ -181,6 +190,32 @@ package body System.HTable is
Table (Index) := E;
end Set;
------------------------
-- Set_If_Not_Present --
------------------------
function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
K : constant Key := Get_Key (E);
Index : constant Header_Num := Hash (K);
Elmt : Elmt_Ptr := Table (Index);
begin
loop
if Elmt = Null_Ptr then
Set_Next (E, Table (Index));
Table (Index) := E;
return True;
elsif Equal (Get_Key (Elmt), K) then
return False;
else
Elmt := Next (Elmt);
end if;
end loop;
end Set_If_Not_Present;
end Static_HTable;
-------------------
......
gcc/ada/s-htable.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1995-2010, AdaCore --
-- Copyright (C) 1995-2011, AdaCore --
-- --
-- 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- --
......@@ -183,6 +183,14 @@ package System.HTable is
-- Returns the latest inserted element pointer with the given Key
-- or null if none.
function Present (K : Key) return Boolean;
-- True if an element whose Get_Key is K is in the table
function Set_If_Not_Present (E : Elmt_Ptr) return Boolean;
-- If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and
-- then returns True. Present (Get_Key (E)) is always True afterward,
-- and the result True indicates E is newly Set.
procedure Remove (K : Key);
-- Removes the latest inserted element pointer associated with the
-- given key if any, does nothing if none.
......
gcc/ada/sem_ch4.adb
......@@ -490,8 +490,14 @@ package body Sem_Ch4 is
Resolve (Expression (E), Type_Id);
-- Allocators generated by the build-in-place expansion mechanism
-- are explicitly marked as coming from source but do not need to be
-- checked for limited initialization. To exclude this case, ensure
-- that the parent of the allocator is a source node.
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then Comes_From_Source (Parent (N))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Type_Id, Expression (E)) then
......
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