From c5ecd6b73c89668590555d62b39f954618c27978 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 11:24:55 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Thomas Quinot * rtsfind.ads, exp_ch3.adb (In_Runtime): Minor code improvement, use Is_RTU instead of using Chars comparisons. 2011-08-29 Thomas Quinot * exp_strm.adb (Build_Mutable_Record_Read_Procedure): Do not create a temporary object if the actual is constrained, and the discriminants read from the stream don't match. 2011-08-29 Tristan Gingold * sem_attr.adb, exp_attr.adb: Add handling of Attribute_System_Allocator_Alignment * snames.ads-tmpl: Add Name_System_Allocator_Alignment and Attribute_System_Allocator_Alignment. * ttypes.ads, get_targ.ads: Add Get_System_Allocator_Alignment. * gcc-interface/targtyps.c, gcc-interface/utils2.c, gcc-interface/gigi.h: Renames get_target_default_allocator_alignment to get_target_system_allocator_alignment. 2011-08-29 Arnaud Charlet * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update dependencies. From-SVN: r178176 --- gcc/ada/ChangeLog | 27 +++++++ gcc/ada/exp_attr.adb | 1 + gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_strm.adb | 63 ++++++++------- gcc/ada/gcc-interface/Make-lang.in | 13 +--- gcc/ada/gcc-interface/Makefile.in | 37 ++++++--- gcc/ada/gcc-interface/gigi.h | 2 +- gcc/ada/gcc-interface/targtyps.c | 6 +- gcc/ada/gcc-interface/utils2.c | 14 ++-- gcc/ada/get_targ.ads | 6 +- gcc/ada/gnat_rm.texi | 14 ++++ gcc/ada/rtsfind.ads | 4 + gcc/ada/sem_attr.adb | 118 +++++++++++++++-------------- gcc/ada/snames.ads-tmpl | 2 + gcc/ada/ttypes.ads | 6 +- 15 files changed, 198 insertions(+), 117 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 57709042729..17845b43a26 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2011-08-29 Thomas Quinot + + * rtsfind.ads, exp_ch3.adb (In_Runtime): Minor code improvement, use + Is_RTU instead of using Chars comparisons. + +2011-08-29 Thomas Quinot + + * exp_strm.adb (Build_Mutable_Record_Read_Procedure): Do not create a + temporary object if the actual is constrained, and the discriminants + read from the stream don't match. + +2011-08-29 Tristan Gingold + + * sem_attr.adb, exp_attr.adb: Add handling of + Attribute_System_Allocator_Alignment + * snames.ads-tmpl: Add Name_System_Allocator_Alignment and + Attribute_System_Allocator_Alignment. + * ttypes.ads, get_targ.ads: Add Get_System_Allocator_Alignment. + * gcc-interface/targtyps.c, gcc-interface/utils2.c, + gcc-interface/gigi.h: Renames get_target_default_allocator_alignment to + get_target_system_allocator_alignment. + +2011-08-29 Arnaud Charlet + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. + 2011-08-29 Arnaud Charlet * exp_ch3.adb (In_Runtime): Fix typo. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 91b6725f43b..c03a040fdaf 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5379,6 +5379,7 @@ package body Exp_Attr is Attribute_Small | Attribute_Storage_Unit | Attribute_Stub_Type | + Attribute_System_Allocator_Alignment | Attribute_Target_Name | Attribute_Type_Class | Attribute_Type_Key | diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ff57fa8cbf5..958033c3ca7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7079,7 +7079,7 @@ package body Exp_Ch3 is S1 := Scope (S1); end loop; - return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; + return Is_RTU (S1, System) or else Is_RTU (S1, Ada); end In_Runtime; ---------------------------- diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 985f8656c66..fe02747705b 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -867,7 +867,7 @@ package body Exp_Strm is Dcls : constant List_Id := New_List; -- Declarations for the 'Read body - Stms : List_Id := New_List; + Stms : constant List_Id := New_List; -- Statements for the 'Read body Disc : Entity_Id; @@ -895,9 +895,6 @@ package body Exp_Strm is -- Statements within the block where we have the constrained temporary begin - - Disc := First_Discriminant (Typ); - -- A mutable type cannot be a tagged type, so we generate a new name -- for the stream procedure. @@ -905,6 +902,23 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + if Is_Unchecked_Union (Typ) then + + -- If this is an unchecked union, the stream procedure is erroneous, + -- because there are no discriminants to read. + + -- This should generate a warning ??? + + Append_To (Stms, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); + return; + end if; + + Disc := First_Discriminant (Typ); + Out_Formal := Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Pnam, Loc), @@ -957,6 +971,14 @@ package body Exp_Strm is Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + -- Save original statement sequence for component assignments, and + -- replace it with Stms. + + Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + -- If Typ has controlled components (i.e. if it is classwide -- or Has_Controlled), or components constrained using the discriminants -- of Typ, then we need to ensure that all component assignments @@ -974,13 +996,10 @@ package body Exp_Strm is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Cstr)))); - Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); - Append_To (Stms, - Make_Block_Statement (Loc, - Declarations => Dcls, - Handled_Statement_Sequence => Parent (Constrained_Stms))); + -- AI05-023-1: Insert discriminant check prior to initialization of the + -- constrained temporary. - Append_To (Constrained_Stms, + Append_To (Stms, Make_Implicit_If_Statement (Pnam, Condition => Make_Attribute_Reference (Loc, @@ -988,28 +1007,20 @@ package body Exp_Strm is Attribute_Name => Name_Constrained), Then_Statements => Discriminant_Checks)); + -- Now insert back original component assignments, wrapped in a block + -- in which V is the constrained temporary. + + Append_To (Stms, + Make_Block_Statement (Loc, + Declarations => Dcls, + Handled_Statement_Sequence => Parent (Constrained_Stms))); + Append_To (Constrained_Stms, Make_Assignment_Statement (Loc, Name => Out_Formal, Expression => Make_Identifier (Loc, Name_V))); - if Is_Unchecked_Union (Typ) then - - -- If this is an unchecked union, the stream procedure is erroneous, - -- because there are no discriminants to read. - - -- This should generate a warning ??? - - Stms := - New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Unchecked_Union_Restriction)); - end if; - Set_Declarations (Decl, Tmps_For_Discs); - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stms)); end Build_Mutable_Record_Read_Procedure; ------------------------------------------ diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 65ee531793d..db4e8852eb1 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -241,8 +241,7 @@ GNAT_ADA_OBJS = \ ada/g-spchge.o \ ada/g-speche.o \ ada/g-u3spch.o \ - ada/get_alfa.o \ - ada/get_scos.o \ + ada/get_alfa.o \ ada/get_targ.o \ ada/gnat.o \ ada/gnatvsn.o \ @@ -2801,12 +2800,6 @@ ada/get_alfa.o : ada/ada.ads ada/a-ioexce.ads ada/a-unccon.ads \ ada/s-string.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ ada/unchdeal.ads -ada/get_scos.o : ada/ada.ads ada/a-ioexce.ads ada/a-unccon.ads \ - ada/get_scos.ads ada/get_scos.adb ada/gnat.ads ada/g-table.ads \ - ada/g-table.adb ada/scos.ads ada/scos.adb ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - ada/get_targ.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads @@ -3362,7 +3355,7 @@ ada/put_scos.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads ada/g-table.ads \ ada/g-table.adb ada/par_sco.ads ada/put_scos.ads ada/put_scos.adb \ ada/scos.ads ada/scos.adb ada/system.ads ada/s-exctab.ads \ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/unchconv.ads ada/unchdeal.ads ada/snames.ads ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3651,7 +3644,7 @@ ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scos.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads ada/g-table.ads \ ada/g-table.adb ada/scos.ads ada/scos.adb ada/system.ads \ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/snames.ads ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 044085592ea..c80480e7b8a 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -274,8 +274,16 @@ INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(srcdir)/config \ ADA_INCLUDES = -I- -I. -I$(srcdir)/ada -INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir)/ada \ - -I$(fsrcdir)/../include -I$(fsrcdir) +INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. -iquote $(fsrcdir)/ada \ + -I$(fsrcdir)/../include + +ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) + # On Windows native the tconfig.h files used by C runtime files needs to have + # the gcc source dir in its include dir list + INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. -iquote $(fsrcdir)/ada \ + -I$(fsrcdir)/../include -I$(fsrcdir) +endif + ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada # Avoid a lot of time thinking about remaking Makefile.in and *.def. @@ -466,7 +474,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) endif endif -ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) +ifeq ($(strip $(filter-out e500% powerpc% wrs vxworks,$(targ))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads default_allocator_alignment) + = ((data_align > system_allocator_alignment) ? make_aligning_type (data_type, data_align, data_size, - default_allocator_alignment, + system_allocator_alignment, POINTER_SIZE / BITS_PER_UNIT) : NULL_TREE); @@ -1986,12 +1986,12 @@ maybe_wrap_free (tree data_ptr, tree data_type) return value, stored in front of the data block at allocation time. */ unsigned int data_align = TYPE_ALIGN (data_type); - unsigned int default_allocator_alignment - = get_target_default_allocator_alignment () * BITS_PER_UNIT; + unsigned int system_allocator_alignment + = get_target_system_allocator_alignment () * BITS_PER_UNIT; tree free_ptr; - if (data_align > default_allocator_alignment) + if (data_align > system_allocator_alignment) { /* DATA_FRONT_PTR (void *) = (void *)DATA_PTR - (void *)sizeof (void *)) */ diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 07a9ab2db6f..6cdbf7509a4 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -95,6 +95,10 @@ package Get_Targ is function Get_Strict_Alignment return Nat; pragma Import (C, Get_Strict_Alignment, "get_target_strict_alignment"); + function Get_System_Allocator_Alignment return Nat; + pragma Import (C, Get_System_Allocator_Alignment, + "get_target_system_allocator_alignment"); + function Get_Double_Float_Alignment return Nat; pragma Import (C, Get_Double_Float_Alignment, "get_target_double_float_alignment"); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 803f210c8a3..ac7ae790b78 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -270,6 +270,7 @@ Implementation Defined Attributes * Small:: * Storage_Unit:: * Stub_Type:: +* System_Allocator_Alignment:: * Target_Name:: * Tick:: * To_Address:: @@ -5752,6 +5753,7 @@ consideration, you should minimize the use of these attributes. * Small:: * Storage_Unit:: * Stub_Type:: +* System_Allocator_Alignment:: * Target_Name:: * Tick:: * To_Address:: @@ -6490,6 +6492,18 @@ type @code{RACW_Stub_Type} declared in the internal implementation-defined unit @code{System.Partition_Interface}. Use of this attribute will create an implicit dependency on this unit. +@node System_Allocator_Alignment +@unnumberedsec System_Allocator_Alignment +@cindex Alignment, allocator +@findex System_Allocator_Alignment +@noindent +@code{Standard'System_Allocator_Alignment} (@code{Standard} is the only +permissible prefix) provides the observable guaranted to be honored by +the system allocator (malloc). This is a static value that can be used +in user storage pools based on malloc either to reject allocation +with alignment too large or to enable a realignment circuitry if the +alignment request is larger than this value. + @node Target_Name @unnumberedsec Target_Name @findex Target_Name diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index d60de40b643..5bfb7166801 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -114,6 +114,10 @@ package Rtsfind is RTU_Null, -- Used as a null entry (will cause an error if referenced) + -- Package Ada + + Ada, + -- Children of Ada Ada_Calendar, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f00c169a96f..3adbac5cdb0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4563,6 +4563,13 @@ package body Sem_Attr is end if; end if; + -------------------------------- + -- System_Allocator_Alignment -- + -------------------------------- + + when Attribute_System_Allocator_Alignment => + Standard_Attribute (Ttypes.System_Allocator_Alignment); + --------- -- Tag -- --------- @@ -7698,61 +7705,62 @@ package body Sem_Attr is -- Note that in some cases, the values have already been folded as -- a result of the processing in Analyze_Attribute. - when Attribute_Abort_Signal | - Attribute_Access | - Attribute_Address | - Attribute_Address_Size | - Attribute_Asm_Input | - Attribute_Asm_Output | - Attribute_Base | - Attribute_Bit_Order | - Attribute_Bit_Position | - Attribute_Callable | - Attribute_Caller | - Attribute_Class | - Attribute_Code_Address | - Attribute_Compiler_Version | - Attribute_Count | - Attribute_Default_Bit_Order | - Attribute_Elaborated | - Attribute_Elab_Body | - Attribute_Elab_Spec | - Attribute_Elab_Subp_Body | - Attribute_Enabled | - Attribute_External_Tag | - Attribute_Fast_Math | - Attribute_First_Bit | - Attribute_Input | - Attribute_Last_Bit | - Attribute_Maximum_Alignment | - Attribute_Old | - Attribute_Output | - Attribute_Partition_ID | - Attribute_Pool_Address | - Attribute_Position | - Attribute_Priority | - Attribute_Read | - Attribute_Result | - Attribute_Storage_Pool | - Attribute_Storage_Size | - Attribute_Storage_Unit | - Attribute_Stub_Type | - Attribute_Tag | - Attribute_Target_Name | - Attribute_Terminated | - Attribute_To_Address | - Attribute_Type_Key | - Attribute_UET_Address | - Attribute_Unchecked_Access | - Attribute_Universal_Literal_String | - Attribute_Unrestricted_Access | - Attribute_Valid | - Attribute_Value | - Attribute_Wchar_T_Size | - Attribute_Wide_Value | - Attribute_Wide_Wide_Value | - Attribute_Word_Size | - Attribute_Write => + when Attribute_Abort_Signal | + Attribute_Access | + Attribute_Address | + Attribute_Address_Size | + Attribute_Asm_Input | + Attribute_Asm_Output | + Attribute_Base | + Attribute_Bit_Order | + Attribute_Bit_Position | + Attribute_Callable | + Attribute_Caller | + Attribute_Class | + Attribute_Code_Address | + Attribute_Compiler_Version | + Attribute_Count | + Attribute_Default_Bit_Order | + Attribute_Elaborated | + Attribute_Elab_Body | + Attribute_Elab_Spec | + Attribute_Elab_Subp_Body | + Attribute_Enabled | + Attribute_External_Tag | + Attribute_Fast_Math | + Attribute_First_Bit | + Attribute_Input | + Attribute_Last_Bit | + Attribute_Maximum_Alignment | + Attribute_Old | + Attribute_Output | + Attribute_Partition_ID | + Attribute_Pool_Address | + Attribute_Position | + Attribute_Priority | + Attribute_Read | + Attribute_Result | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Storage_Unit | + Attribute_Stub_Type | + Attribute_System_Allocator_Alignment | + Attribute_Tag | + Attribute_Target_Name | + Attribute_Terminated | + Attribute_To_Address | + Attribute_Type_Key | + Attribute_UET_Address | + Attribute_Unchecked_Access | + Attribute_Universal_Literal_String | + Attribute_Unrestricted_Access | + Attribute_Valid | + Attribute_Value | + Attribute_Wchar_T_Size | + Attribute_Wide_Value | + Attribute_Wide_Wide_Value | + Attribute_Word_Size | + Attribute_Write => raise Program_Error; end case; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6df207703ac..ff114dcd8a3 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -814,6 +814,7 @@ package Snames is Name_Storage_Size : constant Name_Id := N + $; Name_Storage_Unit : constant Name_Id := N + $; -- GNAT Name_Stream_Size : constant Name_Id := N + $; -- Ada 05 + Name_System_Allocator_Alignment : constant Name_Id := N + $; -- GNAT Name_Tag : constant Name_Id := N + $; Name_Target_Name : constant Name_Id := N + $; -- GNAT Name_Terminated : constant Name_Id := N + $; @@ -1354,6 +1355,7 @@ package Snames is Attribute_Storage_Size, Attribute_Storage_Unit, Attribute_Stream_Size, + Attribute_System_Allocator_Alignment, Attribute_Tag, Attribute_Target_Name, Attribute_Terminated, diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index 8b7749a50a1..bf58eeca1ee 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -188,6 +188,10 @@ package Ttypes is -- The maximum alignment, in storage units, that an object or -- type may require on the target machine. + System_Allocator_Alignment : constant Pos := + Get_System_Allocator_Alignment; + -- The alignment, in storage units, of addresses returned by malloc. + Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field; -- The maximum supported size in bits for a field that is not aligned -- on a storage unit boundary. -- 2.30.2