diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-23 08:48:01 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-23 08:48:01 +0000 |
commit | 3dbca0d576743f296f19099b4ad13a859c1cfb0f (patch) | |
tree | 3934ad8b42d16450bd0d088b678fbab04e0fc5bf /gcc/ada | |
parent | 054247dd94bad885313b902187cb31d406c2ab6a (diff) | |
download | gcc-3dbca0d576743f296f19099b4ad13a859c1cfb0f.tar.gz |
2009-07-23 Gary Dismukes <dismukes@adacore.com>
* sem_ch6.adb (Check_Return_Subtype_Indication): Replace type equality
with test of coverage, to allow specific type objects in extended
returns of class-wide functions. Remove now-unnecessary special-case
tests that allowed this in certain cases of expanded extended returns.
2009-07-23 Javier Miranda <miranda@adacore.com>
* sinfo.ads,sinfo.adb (Entity/Set_Entity): Attribute available in
N_Null_Statements (for SCIL nodes).
(Is_Scil_Node/Set_Is_Scil_Node): New attribute (for SCIL nodes).
(Scil_Nkind/Set_Scil_Nkind): New attribute (for SCIL nodes).
(Scil_Related_Node/Set_Scil_Related_Node): New attribute (for SCIL
nodes).
(Scil_Target_Prim/Set_Scil_Target_Prim): New attribute (for SCIL nodes).
* exp_disp.adb (Expand_Dispatching_Call): Add generation of SCIL node
associated with dispatching call.
(Get_Scil_Node_Kind): New function that returns the kind of SCIL node.
(Make_DT, Make_Tags): Add generation of SCIL nodes associated with
initialization of dispatch tables and initialization of tags.
(New_Scil_Node): New function that creates a new SCIL node.
(Build_Init_Procedure): Add generation of SCIL node associated with the
initialization of tags done in the IP subprogram.
2009-07-23 Ed Schonberg <schonberg@adacore.com>
* errout.adb (Error_Msg_NEL): If the entity in the initial message has
Warnings_Off, do not emit continuation messages.
* sem_ch10.adb: Set Is_Compilation_Unit on generated child subprogram
spec.
2009-07-23 Emmanuel Briot <briot@adacore.com>
* ali.adb: Minor comment update
2009-07-23 Vasiliy Fofanov <fofanov@adacore.com>
* s-win32.ads (HANDLE): Define to be the same size as address type.
Fix copyright.
2009-07-23 Olivier Hainque <hainque@adacore.com>
* g-sse.ads: New file. Root of the SSE facilities trees, with
general description and common declarations.
* g-ssvety.ads: New file. Expose user level SSE vector types.
* impunit.adb (Non_Imp_File_Names_95): Register new units.
* gcc-interface/Makefile.in (x86 32/64 linux, win32): Add
EXTRA_GNATRTL_NONTASKING_OBJS entries for SSE units.
2009-07-23 Ben Brosgol <brosgol@adacore.com>
* gnat_ugn.texi: Wordsmithing.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149974 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 55 | ||||
-rw-r--r-- | gcc/ada/ali.adb | 4 | ||||
-rw-r--r-- | gcc/ada/errout.adb | 4 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 8 | ||||
-rw-r--r-- | gcc/ada/exp_disp.adb | 108 | ||||
-rw-r--r-- | gcc/ada/exp_disp.ads | 23 | ||||
-rw-r--r-- | gcc/ada/g-sse.ads | 102 | ||||
-rw-r--r-- | gcc/ada/g-ssvety.ads | 126 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 5 | ||||
-rw-r--r-- | gcc/ada/gnat_ugn.texi | 124 | ||||
-rw-r--r-- | gcc/ada/impunit.adb | 2 | ||||
-rw-r--r-- | gcc/ada/s-win32.ads | 4 | ||||
-rw-r--r-- | gcc/ada/sem_ch10.adb | 5 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 45 | ||||
-rw-r--r-- | gcc/ada/sinfo.adb | 70 | ||||
-rw-r--r-- | gcc/ada/sinfo.ads | 37 |
16 files changed, 622 insertions, 100 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c34c10f8ea4..a681c6579db 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,58 @@ +2009-07-23 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Check_Return_Subtype_Indication): Replace type equality + with test of coverage, to allow specific type objects in extended + returns of class-wide functions. Remove now-unnecessary special-case + tests that allowed this in certain cases of expanded extended returns. + +2009-07-23 Javier Miranda <miranda@adacore.com> + + * sinfo.ads,sinfo.adb (Entity/Set_Entity): Attribute available in + N_Null_Statements (for SCIL nodes). + (Is_Scil_Node/Set_Is_Scil_Node): New attribute (for SCIL nodes). + (Scil_Nkind/Set_Scil_Nkind): New attribute (for SCIL nodes). + (Scil_Related_Node/Set_Scil_Related_Node): New attribute (for SCIL + nodes). + (Scil_Target_Prim/Set_Scil_Target_Prim): New attribute (for SCIL nodes). + * exp_disp.adb (Expand_Dispatching_Call): Add generation of SCIL node + associated with dispatching call. + (Get_Scil_Node_Kind): New function that returns the kind of SCIL node. + (Make_DT, Make_Tags): Add generation of SCIL nodes associated with + initialization of dispatch tables and initialization of tags. + (New_Scil_Node): New function that creates a new SCIL node. + (Build_Init_Procedure): Add generation of SCIL node associated with the + initialization of tags done in the IP subprogram. + +2009-07-23 Ed Schonberg <schonberg@adacore.com> + + * errout.adb (Error_Msg_NEL): If the entity in the initial message has + Warnings_Off, do not emit continuation messages. + + * sem_ch10.adb: Set Is_Compilation_Unit on generated child subprogram + spec. + +2009-07-23 Emmanuel Briot <briot@adacore.com> + + * ali.adb: Minor comment update + +2009-07-23 Vasiliy Fofanov <fofanov@adacore.com> + + * s-win32.ads (HANDLE): Define to be the same size as address type. + Fix copyright. + +2009-07-23 Olivier Hainque <hainque@adacore.com> + + * g-sse.ads: New file. Root of the SSE facilities trees, with + general description and common declarations. + * g-ssvety.ads: New file. Expose user level SSE vector types. + * impunit.adb (Non_Imp_File_Names_95): Register new units. + * gcc-interface/Makefile.in (x86 32/64 linux, win32): Add + EXTRA_GNATRTL_NONTASKING_OBJS entries for SSE units. + +2009-07-23 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Wordsmithing. + 2009-07-23 Arnaud Charlet <charlet@adacore.com> * prj-conf.ads, prj-conf.adb: Switch to GPLv3. diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 19bbbb05d15..b2357eae970 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -2248,7 +2248,9 @@ package body ALI is end; -- Interfaces are stored in the list of references, - -- although the parent type itself is stored in XE + -- although the parent type itself is stored in XE. + -- The first interface (when there are only + -- interfaces) is stored in XE.Tref*) elsif Ref = Tref_Derived and then Typ = 'R' diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 468afc87156..377c3f4a4f4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1100,6 +1100,10 @@ package body Errout is -- Suppress if no warnings set for either entity or node if No_Warnings (N) or else No_Warnings (E) then + + -- Disable as well continuation messages, if any. + + Last_Killed := True; return; end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3cdf30b81a8..2b2b702813b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2322,6 +2322,14 @@ package body Exp_Ch3 is New_Reference_To (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + if Generate_SCIL then + Prepend_To (Init_Tags_List, + New_Scil_Node + (Nkind => IP_Tag_Init, + Related_Node => First (Init_Tags_List), + Entity => Rec_Type)); + end if; + -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on -- variable size components are initialized later ---see below). diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 165d9080383..7e312dad582 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -643,6 +643,15 @@ package body Exp_Disp is Typ := Non_Limited_View (Typ); end if; + if Generate_SCIL then + Insert_Action (Call_Node, + New_Scil_Node + (Nkind => Dispatching_Call, + Related_Node => Call_Node, + Entity => Typ, + Target_Prim => Subp)); + end if; + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -1596,6 +1605,18 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; + ------------------------ + -- Get_Scil_Node_Kind -- + ------------------------ + + function Get_Scil_Node_Kind (Node : Node_Id) return Scil_Node_Kind is + begin + pragma Assert (Nkind (Node) = N_Null_Statement + and then Is_Scil_Node (Node)); + + return Scil_Node_Kind'Val (UI_To_Int (Scil_Nkind (Node))); + end Get_Scil_Node_Kind; + ------------ -- Has_DT -- ------------ @@ -4221,6 +4242,14 @@ package body Exp_Disp is New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Object_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4247,6 +4276,14 @@ package body Exp_Disp is (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Tag_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + -- Generate: -- DT : Dispatch_Table_Wrapper (Nb_Prim); -- for DT'Alignment use Address'Alignment; @@ -4276,6 +4313,14 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Object_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4302,6 +4347,14 @@ package body Exp_Disp is (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Tag_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => @@ -5070,6 +5123,14 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Object_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5376,6 +5437,14 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Object_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -6066,6 +6135,14 @@ package body Exp_Disp is (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Tag_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims_Ptr, @@ -6100,6 +6177,14 @@ package body Exp_Disp is New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + + if Generate_SCIL then + Insert_Before (Last (Result), + New_Scil_Node + (Nkind => Dispatch_Table_Tag_Init, + Related_Node => Last (Result), + Entity => Typ)); + end if; end if; Set_Is_True_Constant (DT_Ptr); @@ -6322,6 +6407,29 @@ package body Exp_Disp is end if; end New_Value; + ------------------- + -- New_Scil_Node -- + ------------------- + + function New_Scil_Node + (Nkind : Scil_Node_Kind; + Related_Node : Node_Id; + Entity : Entity_Id := Empty; + Target_Prim : Entity_Id := Empty) return Node_Id + is + New_N : Node_Id; + + begin + New_N := New_Node (N_Null_Statement, Sloc (Related_Node)); + Set_Is_Scil_Node (New_N); + Set_Scil_Nkind (New_N, UI_From_Int (Scil_Node_Kind'Pos (Nkind))); + Set_Scil_Related_Node (New_N, Related_Node); + Set_Entity (New_N, Entity); + Set_Scil_Target_Prim (New_N, Target_Prim); + + return New_N; + end New_Scil_Node; + ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 18f751d978d..fab99c28de7 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -30,6 +30,17 @@ with Types; use Types; package Exp_Disp is + ------------------------------- + -- SCIL Node Type Definition -- + ------------------------------- + + type Scil_Node_Kind is ( + Unused, + IP_Tag_Init, + Dispatching_Call, + Dispatch_Table_Object_Init, + Dispatch_Table_Tag_Init); + ------------------------------------- -- Predefined primitive operations -- ------------------------------------- @@ -215,6 +226,9 @@ package Exp_Disp is -- Otherwise they are set to the defining identifier and the subprogram -- body of the generated thunk. + function Get_Scil_Node_Kind (Node : Node_Id) return Scil_Node_Kind; + -- Returns the kind of an SCIL node + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation @@ -309,6 +323,15 @@ package Exp_Disp is -- tagged types this routine imports the forward declaration of the tag -- entity, that will be declared and exported by Make_DT. + function New_Scil_Node + (Nkind : Scil_Node_Kind; + Related_Node : Node_Id; + Entity : Entity_Id := Empty; + Target_Prim : Entity_Id := Empty) return Node_Id; + -- Creates a new Scil node. Related_Node is the AST node associated with + -- this Scil node. Entity is the tagged type associated with the Scil node. + -- For Dispatching_Call nodes, Target_Prim is the dispatching primitive. + function Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id; diff --git a/gcc/ada/g-sse.ads b/gcc/ada/g-sse.ads new file mode 100644 index 00000000000..d0c3ec3fbe4 --- /dev/null +++ b/gcc/ada/g-sse.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S S E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is the root of a set aimed at offering Ada bindings to a subset +-- of the Intel(r) Streaming SIMD Extensions with GNAT. It exposes vector +-- _component_ types together with general comments on the binding contents. + +-- The purpose is to allow access from Ada to the SSE facilities defined in +-- the Intel(r) compiler manuals, in particular in the Intrinsics Reference +-- of the C++ Compiler User's Guide, available from http://www.intel.com. + +-- As of today, essentially one unit is offered: GNAT.SSE.Vector__Types, +-- which exposes Ada types corresponding to the reference types (__m128 and +-- the like) over which GCC builtins will operate. + +-- The exposed Ada types are private. Object initializations or value +-- observations may be performed with unchecked conversions or address +-- overlays, for example: + +-- with Ada.Unchecked_Conversion; +-- with GNAT.SSE.Vector_Types; use GNAT.SSE; use GNAT.SSE.Vector_Types; +-- +-- procedure SSE_Base is +-- +-- -- Core operations +-- +-- function mm_add_ss (A, B : M128) return M128; +-- pragma Import (Intrinsic, mm_add_ss, "__builtin_ia32_addss"); +-- +-- -- User views / conversions or overlays +-- +-- type Vf32_View is array (1 .. 4) of Float; +-- for Vf32_View'Alignment use VECTOR_ALIGN; +-- +-- function To_M128 is new Ada.Unchecked_Conversion (Vf32_View, M128); +-- +-- X, Y, Z : M128; +-- +-- Vz : Vf32_View; +-- for Vz'Address use Z'Address; +-- begin +-- X := To_M128 ((1.0, 1.0, 2.0, 2.0)); +-- Y := To_M128 ((2.0, 2.0, 1.0, 1.0)); +-- Z := mm_add_ss (X, Y); +-- +-- if vz /= (3.0, 1.0, 2.0, 2.0) then +-- raise Program_Error; +-- end if; +-- end; + +-- Use of Unchecked_Union is very tempting, however hits difficulties with +-- e.g. implicit front-end expanded equality operators, which typically +-- feature a subcase comparing the m128 components, not supported by the +-- middle-end. + +package GNAT.SSE is + type Float32 is new Float; + type Float64 is new Long_Float; + type Integer64 is new Long_Long_Integer; + + VECTOR_BYTES : constant := 16; + -- Common size of all the SSE vector types, in bytes. + + VECTOR_ALIGN : constant := 16; + -- Common alignment of all the SSE vector types, in bytes. + + -- Alignment-wise, the reference document reads: + -- << The compiler aligns __m128d and _m128i local and global data to + -- 16-byte boundaries on the stack. >> + -- + -- We apply that consistently to all the Ada vector types, as GCC does + -- for the corresponding C types. + +end GNAT.SSE; diff --git a/gcc/ada/g-ssvety.ads b/gcc/ada/g-ssvety.ads new file mode 100644 index 00000000000..4ad63d852a5 --- /dev/null +++ b/gcc/ada/g-ssvety.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S S E . V e c t o r _ T y p e s -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the Ada __m128 like data types to represent the contents +-- of SSE registers, for use by the SSE intrinsics. + +package GNAT.SSE.Vector_Types is + + -- The reference guide states a few usage guidelines for the C types : + + -- << Since these new data types are not basic ANSI C data types, you + -- must observe the following usage restrictions: + -- + -- * Use new data types only on either side of an assignment, as a + -- return value, or as a parameter. You cannot use it with other + -- arithmetic expressions ("+", "-", and so on). + -- + -- * Use new data types as objects in aggregates, such as unions to + -- access the byte elements and structures. + -- + -- * Use new data types only with the respective intrinsics described + -- in this documentation. >> + + type M128 is private; -- SSE >= 1 + type M128d is private; -- SSE >= 2 + type M128i is private; -- SSE >= 2 + +private + + -- GCC'wise, vector operations operate on objects of vector modes, + -- conveyed through vector types obtained by setting an attribute on what + -- looks like a component typedef. For example, in C (xmmintrin.h): + -- + -- typedef float __v4sf __attribute__ ((__vector_size__ (16))); + + -- We can obtain the same low level GCC effect in Ada with + -- Machine_Attribute pragmas, as in + -- + -- type Vf is new Float; + -- pragma Machine_Attribute (Vf, "vector_size", 16); + -- + -- which makes Vf a 16bytes long V4SFmode type for GCC. The effect on the + -- type layout is not conveyed to the front-end, however, so the latter + -- still sees "Vf" as a 4bytes long single float. This leads to numerous + -- potential pitfalls if this type is directly exposed user land, so we + -- add wrapper records with rep clauses to compensate. + + -- The wrapper records all have a single component of the twisted low + -- level type, so they inherit the mode while the rep clauses convey the + -- size and alignment information to the front-end. + + ------------ + -- M128 -- + ------------ + + -- << The __m128 data type can hold four 32-bit floating-point values. >> + + type V4sf is new Float32; + pragma Machine_Attribute (V4sf, "vector_size", VECTOR_BYTES); + + type M128 is record + Value : V4sf; + end record; + for M128'Size use VECTOR_BYTES * 8; + for M128'Alignment use VECTOR_ALIGN; + + ------------- + -- M128d -- + ------------- + + -- << The __m128d data type can hold two 64-bit floating-point values. >> + + type V2df is new Float64; + pragma Machine_Attribute (V2df, "vector_size", VECTOR_BYTES); + + type M128d is record + Value : V2df; + end record; + for M128d'Size use VECTOR_BYTES * 8; + for M128d'Alignment use VECTOR_ALIGN; + + ------------- + -- M128i -- + ------------- + + -- << The __m128i data type can hold sixteen 8-bit, eight 16-bit, four + -- 32-bit, or two 64-bit integer values. >> + + type V2di is new Integer64; + pragma Machine_Attribute (V2di, "vector_size", VECTOR_BYTES); + + type M128i is record + Value : V2di; + end record; + for M128i'Size use VECTOR_BYTES * 8; + for M128i'Alignment use VECTOR_ALIGN; + +end GNAT.SSE.Vector_Types; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 943cbf572b2..d487716cc53 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1052,6 +1052,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) endif THREADSLIB = -lpthread + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o EXTRA_GNATRTL_TASKING_OBJS=s-linux.o endif @@ -1591,7 +1592,8 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) system.ads<system-mingw.ads endif - EXTRA_GNATRTL_NONTASKING_OBJS = s-win32.o s-winext.o g-regist.o + EXTRA_GNATRTL_NONTASKING_OBJS = \ + s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o MISCLIB = -lws2_32 @@ -2001,6 +2003,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o EXTRA_GNATRTL_TASKING_OBJS=s-linux.o EH_MECHANISM=-gcc THREADSLIB=-lpthread diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 7b1d308e65c..36efbe7ee36 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21209,29 +21209,29 @@ This rule has no parameters. @cindex @code{Complex_Inlined_Subprograms} rule (for @command{gnatcheck}) @noindent -Flags a subprogram body if a pragma Inline is applied to the subprogram or -generic subprogram and this subprogram is too complex to be inlined. +Flags the body of a subprogram (or generic subprogram) if +pragma Inline has been applied to the subprogram but the body +is too complex to be expanded inline. -A subprogram is considered as being too complex for inlining if at least one -of the following conditions is met for its body: +A subprogram (or generic subprogram) is considered too complex for inline +expansion if its body meets at least one of the following conditions: @itemize @bullet @item -number of local declarations + number of statements in subprogram body is -more that a value specified by the @option{N} rule parameter; +The number of local declarations and statements exceeds +a value specified by the @option{N} rule parameter; @item -the body statement sequence contains a loop, if or case statement; - +The body contains a @code{loop}, @code{if} or @code{case} statement; @end itemize @noindent -This rule has the following (mandatory) parameters for the @option{+R} option: +This rule has the following (mandatory) parameter for the @option{+R} option: @table @emph @item N -Positive integer specifying the maximal allowed total number of local -declarations and statements in subprogram body. +Positive integer specifying the maximum allowed total number of local +declarations and statements in the subprogram body. @end table @@ -21252,24 +21252,24 @@ This rule has no parameters. @cindex @code{Deep_Inheritance_Hierarchies} rule (for @command{gnatcheck}) @noindent -Flags tagged derived type declarations and formal tagged derived type -declarations if the corresponding inheritance hierarchy is deeper that -a value specified by the @option{N} rule parameter. +Flags a tagged derived type declaration if its depth (in its inheritance +hierarchy) exceeds the value specified by the @option{N} rule parameter. -The depth of the inheritance hierarchy is the length of the longest -path from the root to a leaf in the type inheritance tree. +The depth of a root tagged type (ie, a tagged type that is not a derived type) +is 0. +If tagged type T2 derives directly from tagged type T1, then the depth of T2 +is one more than the depth of T1. -The rule does not flag interface types and private extension -declarations (in case of a private extension, the correspondong full -declaration is checked) +This rule does not flag interface types or private extension +declarations. In the case of a private extension, the correspondong full +declaration is checked. -This rule has the following parameter for +R option: - -This rule has the following (mandatory) parameters for the @option{+R} option: +This rule has the following (mandatory) parameter for the @option{+R} option: @table @emph @item N -Positive integer specifying the maximal allowed depth of the inheritance tree. +Positive integer specifying the maximal allowed depth of any inheritance +hierarchy. @end table @@ -21278,19 +21278,18 @@ Positive integer specifying the maximal allowed depth of the inheritance tree. @cindex @code{Deeply_Nested_Generics} rule (for @command{gnatcheck}) @noindent -Flags generic declarations nested in another generic declarations if -the level of generics-in-generics nesting is higher that +Flags a generic declaration nested in another generic declaration if +the nesting level of the inner generic exceeds a value specified by the @option{N} rule parameter. -The level of generics-in-generics -nesting is the number of generic declaratons that enclose the given (generic) -declaration. Formal packages are not flagged by this rule. +The nesting level is the number of generic declaratons that enclose the given +(generic) declaration. Formal packages are not flagged by this rule. This rule has the following (mandatory) parameters for the @option{+R} option: @table @emph @item N -Positive integer specifying the maximal allowed level of -generics-in-generics nesting. +Positive integer specifying the maximal allowed nesting level +for a generic declaration. @end table @node Deeply_Nested_Inlining @@ -21298,23 +21297,28 @@ generics-in-generics nesting. @cindex @code{Deeply_Nested_Inlining} rule (for @command{gnatcheck}) @noindent -Flags a subprogram if a pragma @code{Inline} is applied to the corresponding -subprogram (or generic subprogram in case if a flagged subprogram is a generic -instantiation) and the subprogram body contains a call to another inlined -subprogram that results in nested inlining with nesting depth more then -a value specified by the @option{N} rule parameter. This rule -assumes that calls to subprograms in with'ed units are inlided if -at the place of the call the corresponding Inline pragma is visible. This -rule may be usefull for the case when eiter @option{-gnatn} or @option{-gnatN} -option is used when building the executable. +Flags the body of a subprogram (or generic subprogram) if +pragma Inline has been applied to the subprogram but the body +contains a call to another inlined subprogram that results in nested inlining +with nesting depth exceeding the value specified by the +@option{N} rule parameter. + +This rule assumes that pragma Inline applies equally to calls on +subprograms regardless of whether the subprogram declaration appears in the +same compilation unit as the call, or in a separately compiled +(e.g., @i{with}ed) unit. + +This rule may be useful when either the @option{-gnatn} or @option{-gnatN} +option is used. If a subprogram should be flagged according to this rule, the body declaration is flagged only if it is not a completion of a subprogram declaration. -This rule requires the global analysis of all the set of compilation units that -are @command{gnatcheck} arguments, that may affect performance. +This rule requires the global analysis of all the compilation units that +are @command{gnatcheck} arguments; such analysis may affect the tool's +performance. -This rule has the following (mandatory) parameters for the @option{+R} option: +This rule has the following (mandatory) parameter for the @option{+R} option: @table @emph @item N @@ -21366,8 +21370,8 @@ This rule has no parameters. @noindent Flags any non-dispatching call to a dispatching primitive operation, except -when a primitive of a tagged type calls directly the same primitive of the -immediate ancestor. +for the common idiom where a primitive subprogram for a tagged type +directly calls the same primitive subprogram of the type's immediate ancestor. This rule has no parameters. @@ -21487,16 +21491,17 @@ This rule has the following parameters: @table @asis @item @emph{Attribute_Designator} -Adds the specified attribute to the set of attributes to be checked and sets -the checks for all the specified attributes ON. If @emph{Attribute_Designator} -does not correspond to any attribute designator defined in the Ada standard -or to the designator of a GNAT-specific attribute defined in +Adds the specified attribute to the set of attributes to be detected and sets +the detection checks for all the specified attributes ON. +If @emph{Attribute_Designator} +does not denote any attribute defined in the Ada standard +or in @ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference Manual}, it is treated as the name of unknown attribute. @item @code{GNAT} All the GNAT-specific attributes are detected; this sets -the checks for all the specified attributes ON. +the detection checks for all the specified attributes ON. @item @code{ALL} All attributes are detected; this sets the rule ON. @@ -21506,12 +21511,11 @@ All attributes are detected; this sets the rule ON. @table @asis @item @emph{Attribute_Designator} Removes the specified attribute from the set of attributes to be -checked without affecting checks for +detected without affecting detection checks for other attributes. If @emph{Attribute_Designator} does not correspond to any -attribute designator defined in the Ada standard or to the designator -of a GNAT-specific attribute defined in +attribute defined in the Ada standard or in @ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference Manual}, -this option is treated as turning OFF detection of all unknown pragmas. +this option is treated as turning OFF detection of all unknown attributes. @item GNAT Turn OFF detection of all GNAT-specific attributes @@ -21523,20 +21527,20 @@ turn the rule OFF. @end itemize @noindent -Parameters are not case sensitive. If @emph{Attribute_Designator} does not have -the syntax of an Ada identifier and therefore can not be considered as a (part -of an) attribute designator, a diagnostic message is generated and the +Parameters are not case sensitive. If @emph{Attribute_Designator} does not +have the syntax of an Ada identifier and therefore can not be considered as a +(part of an) attribute designator, a diagnostic message is generated and the corresponding parameter is ignored. (If an attribute allows a static expression to be a part of the attribute designator, this expression is -ignored by this rule. +ignored by this rule.) When more then one parameter is given in the same rule option, the parameters -must be separated by a comma. +must be separated by commas. If more then one option for this rule is specified for the gnatcheck call, a new option overrides the previous one(s). -The @option{+R} option with no parameters turns the rule ON with the set of +The @option{+R} option with no parameters turns the rule ON, with the set of attributes to be detected defined by the previous rule options. (By default this set is empty, so if the only option specified for the rule is @option{+RForbidden_Attributes} (with @@ -21818,7 +21822,7 @@ parameter name is not case-sensitive). Declarations of dispatching functions with controlling result and no controlling parameter are never flagged. A subprogram body declaration, subprogram renaming declaration of subprogram -body stub is flagged only if it is not a completion of a pripr subprogram +body stub is flagged only if it is not a completion of a prior subprogram declaration. This rule has no parameters. diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 94112ff8ef5..4264a5a9db7 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -275,6 +275,8 @@ package body Impunit is "g-sptavs", -- GNAT.Spitbol.Table_Vstring "g-string", -- GNAT.Strings "g-strspl", -- GNAT.String_Split + "g-sse ", -- GNAT.SSE + "g-ssvety", -- GNAT.SSE.Vector_Types "g-table ", -- GNAT.Table "g-tasloc", -- GNAT.Task_Lock "g-thread", -- GNAT.Threads diff --git a/gcc/ada/s-win32.ads b/gcc/ada/s-win32.ads index 35975919edd..307647f7366 100644 --- a/gcc/ada/s-win32.ads +++ b/gcc/ada/s-win32.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2009, 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- -- @@ -52,7 +52,7 @@ package System.Win32 is subtype PVOID is Address; - type HANDLE is new Interfaces.C.long; + type HANDLE is new Interfaces.C.ptrdiff_t; INVALID_HANDLE_VALUE : constant HANDLE := -1; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6475bdde1dc..a67acb5539f 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -3829,11 +3829,14 @@ package body Sem_Ch10 is -- immediately visible. -- Find entity for compilation unit, and set its private descendant - -- status as needed. + -- status as needed. Indicate that it is a compilation unit, which is + -- redundant in general, but needed if this is a generated child spec + -- for a child body without previous spec. E_Name := Defining_Entity (Lib_Unit); Set_Is_Child_Unit (E_Name); + Set_Is_Compilation_Unit (E_Name); Set_Is_Private_Descendant (E_Name, Is_Private_Descendant (P_Name) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 56a28607eb2..2b3256824b0 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -583,15 +583,19 @@ package body Sem_Ch6 is Error_Msg_N ("must use anonymous access type", Subtype_Ind); end if; - -- Subtype indication case: check that the types are the same, and - -- statically match if appropriate. Also handle record types with - -- unknown discriminants for which we have built the underlying - -- record view. - - elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) + -- Subtype indication case: check that the return object's type is + -- covered by the result type, and that the subtypes statically match + -- when the result subtype is constrained. Also handle record types + -- with unknown discriminants for which we have built the underlying + -- record view. Coverage is needed to allow specific-type return + -- objects when the result type is class-wide (see AI05-32). + + elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) - and then Underlying_Record_View (Base_Type (R_Stm_Type)) - = Base_Type (R_Type)) + and then + Covers + (Base_Type (R_Type), + Underlying_Record_View (Base_Type (R_Stm_Type)))) then -- A null exclusion may be present on the return type, on the -- function specification, on the object declaration or on the @@ -616,31 +620,6 @@ package body Sem_Ch6 is end if; end if; - -- If the function's result type doesn't match the return object - -- entity's type, then we check for the case where the result type - -- is class-wide, and allow the declaration if the type of the object - -- definition matches the class-wide type. This prevents rejection - -- in the case where the object declaration is initialized by a call - -- to a build-in-place function with a specific result type and the - -- object entity had its type changed to that specific type. This is - -- also allowed in the case where Obj_Decl does not come from source, - -- which can occur for an expansion of a simple return statement of - -- a build-in-place class-wide function when the result expression - -- has a specific type, because a return object with a specific type - -- is created. (Note that the ARG believes that return objects should - -- be allowed to have a type covered by a class-wide result type in - -- any case, so once that relaxation is made (see AI05-32), the above - -- check for type compatibility should be changed to test Covers - -- rather than equality, and the following special test will no - -- longer be needed. ???) - - elsif Is_Class_Wide_Type (R_Type) - and then - (R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) - or else not Comes_From_Source (Obj_Decl)) - then - null; - elsif Etype (Base_Type (R_Type)) = R_Stm_Type and then Is_Null_Extension (Base_Type (R_Type)) then diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 7bd9553798a..56347de3bd5 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1027,7 +1027,8 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Freeze_Entity - or else NT (N).Nkind = N_Attribute_Definition_Clause); + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Null_Statement); return Node4 (N); end Entity; @@ -1703,6 +1704,14 @@ package body Sinfo is return Flag7 (N); end Is_Protected_Subprogram_Body; + function Is_Scil_Node + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + return Flag4 (N); + end Is_Scil_Node; + function Is_Static_Coextension (N : Node_Id) return Boolean is begin @@ -2533,6 +2542,30 @@ package body Sinfo is return Flag18 (N); end Rounded_Result; + function Scil_Nkind + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + return Uint3 (N); + end Scil_Nkind; + + function Scil_Related_Node + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + return Node1 (N); + end Scil_Related_Node; + + function Scil_Target_Prim + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + return Node2 (N); + end Scil_Target_Prim; + function Scope (N : Node_Id) return Node_Id is begin @@ -3850,7 +3883,8 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Freeze_Entity - or else NT (N).Nkind = N_Attribute_Definition_Clause); + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Null_Statement); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Entity; @@ -4517,6 +4551,14 @@ package body Sinfo is Set_Flag7 (N, Val); end Set_Is_Protected_Subprogram_Body; + procedure Set_Is_Scil_Node + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + Set_Flag4 (N, Val); + end Set_Is_Scil_Node; + procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -5347,6 +5389,30 @@ package body Sinfo is Set_Flag18 (N, Val); end Set_Rounded_Result; + procedure Set_Scil_Nkind + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + Set_Uint3 (N, Val); + end Set_Scil_Nkind; + + procedure Set_Scil_Related_Node + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + Set_Node1 (N, Val); + end Set_Scil_Related_Node; + + procedure Set_Scil_Target_Prim + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Null_Statement); + Set_Node2 (N, Val); + end Set_Scil_Target_Prim; + procedure Set_Scope (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index e7b25230e73..4966bb79533 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3836,6 +3836,11 @@ package Sinfo is -- N_Null_Statement -- Sloc points to NULL + -- Is_Scil_Node (Flag4-Sem) + -- Scil_Nkind (Uint3-Sem) + -- Scil_Related_Node (Node1-Sem) + -- Entity (Node4-Sem) + -- Scil_Target_Prim (Node2-Sem) ---------------- -- 5.1 Label -- @@ -8052,6 +8057,9 @@ package Sinfo is function Is_Protected_Subprogram_Body (N : Node_Id) return Boolean; -- Flag7 + function Is_Scil_Node + (N : Node_Id) return Boolean; -- Flag4 + function Is_Static_Coextension (N : Node_Id) return Boolean; -- Flag14 @@ -8307,6 +8315,15 @@ package Sinfo is function Rounded_Result (N : Node_Id) return Boolean; -- Flag18 + function Scil_Nkind + (N : Node_Id) return Uint; -- Uint3 + + function Scil_Related_Node + (N : Node_Id) return Node_Id; -- Node1 + + function Scil_Target_Prim + (N : Node_Id) return Node_Id; -- Node2 + function Scope (N : Node_Id) return Node_Id; -- Node3 @@ -8949,6 +8966,9 @@ package Sinfo is procedure Set_Is_Protected_Subprogram_Body (N : Node_Id; Val : Boolean := True); -- Flag7 + procedure Set_Is_Scil_Node + (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True); -- Flag14 @@ -9204,6 +9224,15 @@ package Sinfo is procedure Set_Rounded_Result (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Scil_Nkind + (N : Node_Id; Val : Uint); -- Uint3 + + procedure Set_Scil_Related_Node + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Scil_Target_Prim + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Scope (N : Node_Id; Val : Node_Id); -- Node3 @@ -11144,6 +11173,7 @@ package Sinfo is pragma Inline (Is_Overloaded); pragma Inline (Is_Power_Of_2_For_Shift); pragma Inline (Is_Protected_Subprogram_Body); + pragma Inline (Is_Scil_Node); pragma Inline (Is_Static_Coextension); pragma Inline (Is_Static_Expression); pragma Inline (Is_Subprogram_Descriptor); @@ -11229,6 +11259,9 @@ package Sinfo is pragma Inline (Reverse_Present); pragma Inline (Right_Opnd); pragma Inline (Rounded_Result); + pragma Inline (Scil_Nkind); + pragma Inline (Scil_Related_Node); + pragma Inline (Scil_Target_Prim); pragma Inline (Scope); pragma Inline (Select_Alternatives); pragma Inline (Selector_Name); @@ -11439,6 +11472,7 @@ package Sinfo is pragma Inline (Set_Is_Overloaded); pragma Inline (Set_Is_Power_Of_2_For_Shift); pragma Inline (Set_Is_Protected_Subprogram_Body); + pragma Inline (Set_Is_Scil_Node); pragma Inline (Set_Has_Self_Reference); pragma Inline (Set_Is_Static_Coextension); pragma Inline (Set_Is_Static_Expression); @@ -11524,6 +11558,9 @@ package Sinfo is pragma Inline (Set_Reverse_Present); pragma Inline (Set_Right_Opnd); pragma Inline (Set_Rounded_Result); + pragma Inline (Set_Scil_Nkind); + pragma Inline (Set_Scil_Related_Node); + pragma Inline (Set_Scil_Target_Prim); pragma Inline (Set_Scope); pragma Inline (Set_Select_Alternatives); pragma Inline (Set_Selector_Name); |