+2014-07-29 Olivier Hainque <hainque@adacore.com>
+
+ * g-debpoo.adb
+ (Default_Alignment): Rename as Storage_Alignment. This is not
+ a "default" that can be overriden. Augment comment to clarify
+ intent and document why we need to manage alignment padding.
+ (Header_Offset): Set to Header'Object_Size instead of 'Size
+ rounded up to Storage_Alignment. Storage_Alignment on the
+ allocation header is not required by our internals so was
+ overkill. 'Object_Size is enough to ensure proper alignment
+ of the header address when substracted from a storage address
+ aligned on Storage_Alignment.
+ (Minimum_Allocation): Rename as Extra_Allocation, conveying that
+ this is always added on top of the incoming allocation requests.
+ (Align): New function, to perform alignment rounding operations.
+ (Allocate): Add comments on the Storage_Address computation
+ scheme and adjust so that the alignment padding applies to that
+ (Storage_Address) only.
+
+2014-07-29 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch3.adb (Default_Initialize_Object): Remove incorrect
+ pragma Unreferenced.
+ * cstand.adb (Create_Standard): Use E_Array_Type for standard
+ string types. Make sure index of Any_String/Any_Array is in a list.
+ * errout.adb: Minor reformatting.
+
2014-07-29 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Clean up and correct documentation of warnings.
-- Creates entities for all predefined floating point types, and
-- adds these to the Predefined_Float_Types list in package Standard.
+ procedure Make_Dummy_Index (E : Entity_Id);
+ -- Called to provide a dummy index field value for Any_Array/Any_String
+
procedure Pack_String_Type (String_Type : Entity_Id);
-- Generate proper tree for pragma Pack that applies to given type, and
-- mark type as having the pragma.
end Create_Float_Types;
----------------------
+ -- Make_Dummy_Index --
+ ----------------------
+
+ procedure Make_Dummy_Index (E : Entity_Id) is
+ Index : Node_Id;
+ Dummy : List_Id;
+
+ begin
+ Index :=
+ Make_Range (Sloc (E),
+ Low_Bound => Make_Integer (Uint_0),
+ High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
+ Set_Etype (Index, Standard_Integer);
+ Set_First_Index (E, Index);
+
+ -- Make sure Index is a list as required, so Next_Index is Empty
+
+ Dummy := New_List (Index);
+ end Make_Dummy_Index;
+
+ ----------------------
-- Pack_String_Type --
----------------------
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_String), Tdef_Node);
- Set_Ekind (Standard_String, E_String_Type);
+ Set_Ekind (Standard_String, E_Array_Type);
Set_Etype (Standard_String, Standard_String);
Set_Component_Type (Standard_String, Standard_Character);
Set_Component_Size (Standard_String, Uint_8);
-- Set index type of String
- E_Id := First
- (Subtype_Marks (Type_Definition (Parent (Standard_String))));
+ E_Id :=
+ First (Subtype_Marks (Type_Definition (Parent (Standard_String))));
Set_First_Index (Standard_String, E_Id);
Set_Entity (E_Id, Standard_Positive);
Set_Etype (E_Id, Standard_Positive);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_String, E_String_Type);
+ Set_Ekind (Standard_Wide_String, E_Array_Type);
Set_Etype (Standard_Wide_String, Standard_Wide_String);
Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
Set_Component_Size (Standard_Wide_String, Uint_16);
-- Set index type of Wide_String
- E_Id := First
- (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String))));
+ E_Id :=
+ First
+ (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String))));
Set_First_Index (Standard_Wide_String, E_Id);
Set_Entity (E_Id, Standard_Positive);
Set_Etype (E_Id, Standard_Positive);
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_Wide_String, E_String_Type);
+ Set_Ekind (Standard_Wide_Wide_String, E_Array_Type);
Set_Etype (Standard_Wide_Wide_String,
Standard_Wide_Wide_String);
Set_Component_Type (Standard_Wide_Wide_String,
-- Set index type of Wide_Wide_String
- E_Id := First
- (Subtype_Marks (Type_Definition (Parent (Standard_Wide_Wide_String))));
+ E_Id :=
+ First
+ (Subtype_Marks
+ (Type_Definition (Parent (Standard_Wide_Wide_String))));
Set_First_Index (Standard_Wide_Wide_String, E_Id);
Set_Entity (E_Id, Standard_Positive);
Set_Etype (E_Id, Standard_Positive);
Make_Name (Any_Character, "a character type");
Any_Array := New_Standard_Entity;
- Set_Ekind (Any_Array, E_String_Type);
+ Set_Ekind (Any_Array, E_Array_Type);
Set_Scope (Any_Array, Standard_Standard);
Set_Etype (Any_Array, Any_Array);
Set_Component_Type (Any_Array, Any_Character);
Init_Size_Align (Any_Array);
Make_Name (Any_Array, "an array type");
+ Make_Dummy_Index (Any_Array);
Any_Boolean := New_Standard_Entity;
Set_Ekind (Any_Boolean, E_Enumeration_Type);
Make_Name (Any_Scalar, "a scalar type");
Any_String := New_Standard_Entity;
- Set_Ekind (Any_String, E_String_Type);
+ Set_Ekind (Any_String, E_Array_Type);
Set_Scope (Any_String, Standard_Standard);
Set_Etype (Any_String, Any_String);
Set_Component_Type (Any_String, Any_Character);
Init_Size_Align (Any_String);
Make_Name (Any_String, "a string type");
-
- declare
- Index : Node_Id;
-
- begin
- Index :=
- Make_Range (Stloc,
- Low_Bound => Make_Integer (Uint_0),
- High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
- Set_Etype (Index, Standard_Integer);
- Set_First_Index (Any_String, Index);
- end;
+ Make_Dummy_Index (Any_String);
Raise_Type := New_Standard_Entity;
Decl := New_Node (N_Full_Type_Declaration, Stloc);
function Is_String_Type (Id : E) return B is
begin
- return Ekind (Id) in String_Kind
- or else (Is_Array_Type (Id)
- and then Id /= Any_Composite
- and then Number_Dimensions (Id) = 1
- and then Is_Character_Type (Component_Type (Id)));
+ return Is_Array_Type (Id)
+ and then Id /= Any_Composite
+ and then Number_Dimensions (Id) = 1
+ and then Is_Character_Type (Component_Type (Id));
end Is_String_Type;
-------------------------------
T : Node_Id;
begin
- if Ekind (Id) in String_Kind then
+ if Ekind (Id) = E_String_Literal_Subtype then
return 1;
else
T := First_Index (Id);
while Present (T) loop
N := N + 1;
- T := Next (T);
+ Next_Index (T);
end loop;
return N;
E_Record_Subtype =>
Kind := E_Record_Subtype;
- when E_String_Type |
- E_String_Subtype =>
- Kind := E_String_Subtype;
-
when Enumeration_Kind =>
Kind := E_Enumeration_Subtype;
-- all the extra formals (see description of Extra_Formals field).
-- First_Index (Node17)
--- Defined in array types and subtypes and in string types and subtypes.
--- By introducing implicit subtypes for the index constraints, we have
--- the same structure for constrained and unconstrained arrays, subtype
--- marks and discrete ranges are both represented by a subtype. This
--- function returns the tree node corresponding to an occurrence of the
--- first index (NOT the entity for the type). Subsequent indices are
--- obtained using Next_Index. Note that this field is defined for the
--- case of string literal subtypes, but is always Empty.
+-- Defined in array types and subtypes. By introducing implicit subtypes
+-- for the index constraints, we have the same structure for constrained
+-- and unconstrained arrays, subtype marks and discrete ranges are
+-- both represented by a subtype. This function returns the tree node
+-- corresponding to an occurrence of the first index (NOT the entity for
+-- the type). Subsequent indices are obtained using Next_Index. Note that
+-- this field is defined for the case of string literal subtypes, but is
+-- always Empty.
-- First_Literal (Node17)
-- Defined in all enumeration types, including character and boolean
-- or the use of an anonymous array subtype.
E_String_Type,
- -- A string type, i.e. an array type whose component type is a character
- -- type, and for which string literals can thus be written.
-
E_String_Subtype,
- -- A string subtype, created by an explicit subtype declaration for a
- -- string type, or the use of an anonymous subtype of a string type,
+ -- These are obsolete and not used any more, they are retained to ease
+ -- transition in getting rid of these obsolete entries.
E_String_Literal_Subtype,
-- A special string subtype, used only to describe the type of a string
subtype Aggregate_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
- -- E_String_Type
- -- E_String_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
subtype Array_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
- -- E_String_Type
- -- E_String_Subtype
E_String_Literal_Subtype;
subtype Assignable_Kind is Entity_Kind range
subtype Composite_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
- -- E_String_Type
- -- E_String_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- E_Floating_Point_Type
E_Floating_Point_Subtype;
- subtype String_Kind is Entity_Kind range
- E_String_Type ..
- -- E_String_Subtype
- E_String_Literal_Subtype;
-
subtype Subprogram_Kind is Entity_Kind range
E_Function ..
-- E_Operator
-- E_Anonymous_Access_Type
-- E_Array_Type
-- E_Array_Subtype
- -- E_String_Type
- -- E_String_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Subtype
-- E_Class_Wide_Type
-- Type_High_Bound (synth)
-- (plus type attributes)
- -- E_String_Type
- -- E_String_Subtype
- -- First_Index (Node17)
- -- Component_Type (Node20) (base type only)
- -- Static_Real_Or_String_Predicate (Node25)
- -- Is_Constrained (Flag12)
- -- SSO_Set_High_By_Default (Flag273) (base type only)
- -- SSO_Set_Low_By_Default (Flag272) (base type only)
- -- Next_Index (synth)
- -- Number_Dimensions (synth)
- -- (plus type attributes)
-
-- E_String_Literal_Subtype
-- String_Literal_Low_Bound (Node15)
-- String_Literal_Length (Uint16)
Err_Flag :=
E /= No_Error_Msg
- and then Errors.Table (E).Line = N
- and then Errors.Table (E).Sfile = Sfile;
+ and then Errors.Table (E).Line = N
+ and then Errors.Table (E).Sfile = Sfile;
Output_Source_Line (N, Sfile, Err_Flag);
Obj_Ref : Node_Id;
Dummy : Entity_Id;
- pragma Unreferenced (Dummy);
- -- This variable captures an unused dummy internal entity, see the
- -- comment associated with its use.
+ -- This variable captures a dummy internal entity, see the comment
+ -- associated with its use.
-- Start of processing for Default_Initialize_Object
-- Processing that is done only for base types
- if Ekind (Arr) = E_Array_Type then -- what about E_String_Type ???
+ if Ekind (Arr) = E_Array_Type then
-- Deal with default setting of reverse storage order
if Has_Pragma_Pack (Arr)
and then not Present (Comp_Size_C)
- and then
- (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
+ and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
and then Esize (Base_Type (Ctyp)) = Csiz + 1
then
Error_Msg_Uint_1 := Csiz;
if Known_Static_Esize (Component_Type (Arr))
and then Esize (Component_Type (Arr)) = Csiz
then
- Set_Has_Non_Standard_Rep
- (Base_Type (Arr), False);
+ Set_Has_Non_Standard_Rep (Base_Type (Arr), False);
end if;
-- In all other cases, packing is indeed needed
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
package body GNAT.Debug_Pools is
- Default_Alignment : constant := Standard'Maximum_Alignment;
- -- Alignment used for the memory chunks returned by Allocate. Using this
- -- value guarantees that this alignment will be compatible with all types
- -- and at the same time makes it easy to find the location of the extra
- -- header allocated for each chunk.
+ Storage_Alignment : constant := Standard'Maximum_Alignment;
+ -- Alignment enforced for all the memory chunks returned by Allocate,
+ -- maximized to make sure that it will be compatible with all types.
+ --
+ -- The addresses returned by the underlying low-level allocator (be it
+ -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned
+ -- on some targets, so we manage the needed alignment padding ourselves
+ -- systematically. Use of a common value for every allocation allows
+ -- significant simplifications in the code, nevertheless, for improved
+ -- robustness and efficiency overall.
+
+ -- We combine a few internal devices to offer the pool services:
+ --
+ -- * A management header attached to each allocated memory block, located
+ -- right ahead of it, like so:
+ --
+ -- Storage Address returned by the pool,
+ -- aligned on Storage_Alignment
+ -- v
+ -- +------+--------+---------------------
+ -- | ~~~~ | HEADER | USER DATA ... |
+ -- +------+--------+---------------------
+ -- <---->
+ -- alignment
+ -- padding
+ --
+ -- The alignment padding is required
+ --
+ -- * A validity bitmap, which holds a validity bit for blocks managed by
+ -- the pool. Enforcing Storage_Alignment on those blocks allows efficient
+ -- validity management.
+ --
+ -- * A list of currently used blocks.
Max_Ignored_Levels : constant Natural := 10;
-- Maximum number of levels that will be ignored in backtraces. This is so
(Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
Header_Offset : constant Storage_Count :=
- Default_Alignment *
- ((Allocation_Header'Size / System.Storage_Unit
- + Default_Alignment - 1) / Default_Alignment);
- -- Offset of user data after allocation header
-
- Minimum_Allocation : constant Storage_Count :=
- Default_Alignment - 1 + Header_Offset;
- -- Minimal allocation: size of allocation_header rounded up to next
- -- multiple of default alignment + worst-case padding.
+ (Allocation_Header'Object_Size / System.Storage_Unit);
+ -- Offset, in bytes, from start of allocation Header to start of User
+ -- data. The start of user data is assumed to be aligned at least as much
+ -- as what the header type requires, so applying this offset yields a
+ -- suitably aligned address as well.
+
+ Extra_Allocation : constant Storage_Count :=
+ (Storage_Alignment - 1 + Header_Offset);
+ -- Amount we need to secure in addition to the user data for a given
+ -- allocation request: room for the allocation header plus worst-case
+ -- alignment padding.
-----------------------
-- Local subprograms --
-----------------------
+ function Align (Addr : Integer_Address) return Integer_Address;
+ pragma Inline (Align);
+ -- Return the next address aligned on Storage_Alignment from Addr.
+
function Find_Or_Create_Traceback
(Pool : Debug_Pool;
Kind : Traceback_Kind;
-- addresses internal to this package). Depth is the number of levels that
-- the user is interested in.
+ -----------
+ -- Align --
+ -----------
+
+ function Align (Addr : Integer_Address) return Integer_Address is
+ Factor : constant Integer_Address := Storage_Alignment;
+ begin
+ return ((Addr + Factor - 1) / Factor) * Factor;
+ end Align;
+
---------------
-- Header_Of --
---------------
-- that two chunk of allocated data are very far from each other.
Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB
- Validity_Divisor : constant := Default_Alignment * System.Storage_Unit;
+ Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit;
Max_Validity_Byte_Index : constant :=
Memory_Chunk_Size / Validity_Divisor;
Int_Storage : constant Integer_Address := To_Integer (Storage);
begin
- -- The pool only returns addresses aligned on Default_Alignment so
+ -- The pool only returns addresses aligned on Storage_Alignment so
-- anything off cannot be a valid block address and we can return
-- early in this case. We actually have to since our data structures
-- map validity bits for such aligned addresses only.
- if Int_Storage mod Default_Alignment /= 0 then
+ if Int_Storage mod Storage_Alignment /= 0 then
return False;
end if;
Offset : constant Integer_Address :=
(Int_Storage -
(Block_Number * Memory_Chunk_Size)) /
- Default_Alignment;
+ Storage_Alignment;
Bit : constant Byte :=
2 ** Natural (Offset mod System.Storage_Unit);
begin
Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number);
Offset : constant Integer_Address :=
(Int_Storage - (Block_Number * Memory_Chunk_Size)) /
- Default_Alignment;
+ Storage_Alignment;
Bit : constant Byte :=
2 ** Natural (Offset mod System.Storage_Unit);
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
+
pragma Unreferenced (Alignment);
- -- Ignored, we always force 'Default_Alignment
+ -- Ignored, we always force Storage_Alignment
type Local_Storage_Array is new Storage_Array
- (1 .. Size_In_Storage_Elements + Minimum_Allocation);
+ (1 .. Size_In_Storage_Elements + Extra_Allocation);
type Ptr is access Local_Storage_Array;
-- On some systems, we might want to physically protect pages against
P := new Local_Storage_Array;
end;
- Storage_Address :=
- To_Address
- (Default_Alignment *
- ((To_Integer (P.all'Address) + Default_Alignment - 1)
- / Default_Alignment)
- + Integer_Address (Header_Offset));
+ -- Compute Storage_Address, aimed at receiving user data. We need room
+ -- for the allocation header just ahead of the user data space plus
+ -- alignment padding so Storage_Address is aligned on Storage_Alignment,
+ -- like so:
+ --
+ -- Storage_Address, aligned
+ -- on Storage_Alignment
+ -- v
+ -- | ~~~~ | Header | User data ... |
+ -- ^........^
+ -- Header_Offset
+ --
+ -- Header_Offset is fixed so moving back and forth between user data
+ -- and allocation header is straightforward. The value is also such
+ -- that the header type alignment is honored when starting from
+ -- Default_alignment.
+
+ -- For the purpose of computing Storage_Address, we just do as if the
+ -- header was located first, followed by the alignment padding:
+
+ Storage_Address := To_Address
+ (Align (To_Integer (P.all'Address) + Integer_Address (Header_Offset)));
-- Computation is done in Integer_Address, not Storage_Offset, because
-- the range of Storage_Offset may not be large enough.
pragma Assert ((Storage_Address - System.Null_Address)
- mod Default_Alignment = 0);
+ mod Storage_Alignment = 0);
pragma Assert (Storage_Address + Size_In_Storage_Elements
<= P.all'Address + P'Length);
pragma Warnings (Off);
-- Turn warning on alignment for convert call off. We know that in fact
-- this conversion is safe since P itself is always aligned on
- -- Default_Alignment.
+ -- Storage_Alignment.
Header_Of (Storage_Address).all :=
(Allocation_Address => P.all'Address,
(Output_File (Pool),
"info: Freeing physical memory "
& Storage_Count'Image
- ((abs Header.Block_Size) + Minimum_Allocation)
+ ((abs Header.Block_Size) + Extra_Allocation)
& " bytes at 0x"
& Address_Image (Header.Allocation_Address));
end if;
& Storage_Count'Image (Size_In_Storage_Elements)
& " bytes at 0x" & Address_Image (Storage_Address)
& " (physically"
- & Storage_Count'Image (Header.Block_Size + Minimum_Allocation)
+ & Storage_Count'Image (Header.Block_Size + Extra_Allocation)
& " bytes at 0x" & Address_Image (Header.Allocation_Address)
& "), at ");
Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
E_Signed_Integer_Subtype => 'I',
E_Signed_Integer_Type => 'I',
E_String_Literal_Subtype => ' ',
- E_String_Subtype => 'S',
- E_String_Type => 'S',
E_Subprogram_Type => ' ',
E_Task_Subtype => 'T',
E_Task_Type => 'T',
E_Variable => '*',
E_Void => ' ',
+ -- These are dummy entries which can be removed when we finally get
+ -- rid of these obsolete entries once and for all.
+
+ E_String_Type => ' ',
+ E_String_Subtype => ' ',
+
-- The following entities are not ones to which we gather the cross-
-- references, since it does not make sense to do so (e.g. references to
-- a package are to the spec, not the body) Indeed the occurrence of the
if Token = Tok_Right_Paren then
Scan (In_Tree);
end if;
-
end Parse_String_Type_Declaration;
--------------------------------
-- Array types and string types
- when E_Array_Type | E_String_Type =>
+ when E_Array_Type =>
Write_Header;
Write_Str ("array (");
projects / platform / upstream / linaro-gcc.git / commitdiff