-- --
------------------------------------------------------------------------------
--- Assertions in this package are too slow, and are mostly needed when working
--- on this package itself, or on gen_il, so we disable them.
--- To debug low-level bugs in this area, comment out the following pragma,
--- and run with -gnatd_v.
-
-pragma Assertion_Policy (Ignore);
-
with Aspects; use Aspects;
with Debug; use Debug;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
-with Seinfo; use Seinfo;
with Sinfo.Utils; use Sinfo.Utils;
with System.Storage_Elements;
function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count;
-- Number of slots belonging to N. This can be less than
- -- Size_In_Slots_To_Alloc for entities.
+ -- Size_In_Slots_To_Alloc for entities. Includes both header
+ -- and dynamic slots.
+
+ function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count;
+ -- Just counts the number of dynamic slots
function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Slot_Count;
function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count;
-- to allocate the max, because we don't know the Ekind when this is
-- called.
- function Off_0 (N : Node_Id) return Node_Offset;
- -- Offset of the first slot of N (offset 0) in Slots.Table
+ function Off_F (N : Node_Id) return Node_Offset with Inline;
+ -- Offset of the first dynamic slot of N in Slots.Table.
+ -- The actual offset of this slot from the start of the node
+ -- is not 0; this is logically the first slot after the header
+ -- slots.
+
+ function Off_0 (N : Node_Id) return Node_Offset'Base with Inline;
+ -- This is for zero-origin addressing of the dynamic slots.
+ -- It points to slot 0 of N in Slots.Table, which does not exist,
+ -- because the first few slots are stored in the header.
- function Off_L (N : Node_Id) return Node_Offset;
+ function Off_L (N : Node_Id) return Node_Offset with Inline;
-- Offset of the last slot of N in Slots.Table
- procedure Zero_Slots (First, Last : Node_Offset) with Inline;
- -- Set slots in the range F..L to zero
+ procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) with Inline;
+ -- Set dynamic slots in the range First..Last to zero
+
+ procedure Zero_Header_Slots (N : Node_Or_Entity_Id) with Inline;
+ -- Zero the header slots belonging to N
procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline;
- -- Zero the slots belonging to N
+ -- Zero the slots belonging to N (both header and dynamic)
- procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count)
+ procedure Copy_Dynamic_Slots
+ (From, To : Node_Offset; Num_Slots : Slot_Count)
with Inline;
-- Copy Num_Slots slots from From to To. Caller is responsible for ensuring
-- that the Num_Slots at To are a reasonable place to copy to.
procedure Copy_Slots (Source, Destination : Node_Id) with Inline;
- -- Copies the slots of Source to Destination; uses the node kind to
- -- determine the Num_Slots.
+ -- Copies the slots (both header and dynamic) of Source to Destination;
+ -- uses the node kind to determine the Num_Slots.
function Get_Field_Value
- (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit;
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit;
-- Get any field value as a Field_Size_32_Bit. If the field is smaller than
-- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in
-- the Nkind of N.
procedure Set_Field_Value
- (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit);
+ (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit);
-- Set any field value as a Field_Size_32_Bit. If the field is smaller than
-- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small
-- enough. The Field must be present in the Nkind of N.
-- Called whenever Nkind is modified. Raises an exception if not all
-- vanishing fields are in their initial zero state.
- function Get_Field_Value
- (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit;
- procedure Set_Field_Value
- (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit);
procedure Check_Vanishing_Fields
(Old_N : Entity_Id; New_Kind : Entity_Kind);
-- Above are the same as the ones for nodes, but for entities
pragma Assert (N'Valid);
pragma Assert (N <= Node_Offsets.Last);
- pragma Assert (Off_0 (N) <= Off_L (N));
+ pragma Assert (Off_L (N) >= Off_0 (N));
+ pragma Assert (Off_L (N) >= Off_F (N) - 1);
pragma Assert (Off_L (N) <= Slots.Last);
pragma Assert (Nkind (N)'Valid);
pragma Assert (Nkind (N) /= N_Unused_At_End);
function Cast is new
Unchecked_Conversion (Field_Size_1_Bit, Field_Type);
+ Val : constant Field_Size_1_Bit := Get_1_Bit_Val (N, Offset);
begin
- return Cast (Get_1_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_1_Bit_Field;
function Get_2_Bit_Field
function Cast is new
Unchecked_Conversion (Field_Size_2_Bit, Field_Type);
+ Val : constant Field_Size_2_Bit := Get_2_Bit_Val (N, Offset);
begin
- return Cast (Get_2_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_2_Bit_Field;
function Get_4_Bit_Field
function Cast is new
Unchecked_Conversion (Field_Size_4_Bit, Field_Type);
+ Val : constant Field_Size_4_Bit := Get_4_Bit_Val (N, Offset);
begin
- return Cast (Get_4_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_4_Bit_Field;
function Get_8_Bit_Field
function Cast is new
Unchecked_Conversion (Field_Size_8_Bit, Field_Type);
+ Val : constant Field_Size_8_Bit := Get_8_Bit_Val (N, Offset);
begin
- return Cast (Get_8_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_8_Bit_Field;
function Get_32_Bit_Field
function Cast is new
Unchecked_Conversion (Field_Size_32_Bit, Field_Type);
- Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset));
+ Val : constant Field_Size_32_Bit := Get_32_Bit_Val (N, Offset);
+ Result : constant Field_Type := Cast (Val);
-- Note: declaring Result here instead of directly returning
-- Cast (...) helps CodePeer understand that there are no issues
-- around uninitialized variables.
Set_32_Bit_Val (N, Offset, Cast (Val));
end Set_32_Bit_Field;
+ pragma Style_Checks ("M90");
+
+ -----------------------------------
+ -- Low-level getters and setters --
+ -----------------------------------
+
+ -- In the getters and setters below, we use shifting and masking to
+ -- simulate packed arrays. F_Size is the field size in bits. Mask is
+ -- that number of 1 bits in the low-order bits. F_Per_Slot is the number
+ -- of fields per slot. Slot_Off is the offset of the slot of interest.
+ -- S is the slot at that offset. V is the amount to shift by.
+
+ function In_NH (Slot_Off : Field_Offset) return Boolean is
+ (Slot_Off < Seinfo.N_Head);
+ -- In_NH stands for "in Node_Header", not "in New Hampshire"
+
+ function Get_Slot
+ (N : Node_Or_Entity_Id; Slot_Off : Field_Offset)
+ return Slot is
+ (if In_NH (Slot_Off) then
+ Node_Offsets.Table (N).Slots (Slot_Off)
+ else Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off));
+ -- Get the slot, either directly from the node header, or indirectly
+ -- from the Slots table.
+
function Get_1_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit
is
- -- We wish we were using packed arrays, but instead we're simulating
- -- them with modular integers. L here (and elsewhere) is the 'Length
- -- of that simulated array.
- L : constant Field_Offset := Slot_Size / 1;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 1;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_1_Bit :=
+ Field_Size_1_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_1_Bit (Shift_Right (S, V) and 1);
+ return Raw;
end Get_1_Bit_Val;
function Get_2_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit
is
- L : constant Field_Offset := Slot_Size / 2;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 2;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_2_Bit :=
+ Field_Size_2_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_2_Bit (Shift_Right (S, V) and 3);
+ return Raw;
end Get_2_Bit_Val;
function Get_4_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit
is
- L : constant Field_Offset := Slot_Size / 4;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 4;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_4_Bit :=
+ Field_Size_4_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_4_Bit (Shift_Right (S, V) and 15);
+ return Raw;
end Get_4_Bit_Val;
function Get_8_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit
is
- L : constant Field_Offset := Slot_Size / 8;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 8;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_8_Bit :=
+ Field_Size_8_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_8_Bit (Shift_Right (S, V) and 255);
+ return Raw;
end Get_8_Bit_Val;
function Get_32_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit
is
- pragma Debug (Validate_Node_And_Offset (N, Offset));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ F_Size : constant := 32;
+ -- No Mask needed
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_32_Bit :=
+ Field_Size_32_Bit (S);
begin
- return Field_Size_32_Bit (S);
+ return Raw;
end Get_32_Bit_Val;
+ type Slot_Ptr is access all Slot;
+ function Get_Slot_Ptr
+ (N : Node_Or_Entity_Id; Slot_Off : Field_Offset)
+ return Slot_Ptr is
+ (if In_NH (Slot_Off) then
+ Node_Offsets.Table (N).Slots (Slot_Off)'Access
+ else Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off)'Access);
+
procedure Set_1_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit)
is
- L : constant Field_Offset := Slot_Size / 1;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 1;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ Ptr : constant Slot_Ptr := Get_Slot_Ptr (N, Slot_Off);
+ S : Slot renames Ptr.all;
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (1, V)) or Shift_Left (Slot (Val), V);
+ S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V);
end Set_1_Bit_Val;
procedure Set_2_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit)
is
- L : constant Field_Offset := Slot_Size / 2;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 2;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ Ptr : constant Slot_Ptr := Get_Slot_Ptr (N, Slot_Off);
+ S : Slot renames Ptr.all;
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (3, V)) or Shift_Left (Slot (Val), V);
+ S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V);
end Set_2_Bit_Val;
procedure Set_4_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit)
is
- L : constant Field_Offset := Slot_Size / 4;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 4;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ Ptr : constant Slot_Ptr := Get_Slot_Ptr (N, Slot_Off);
+ S : Slot renames Ptr.all;
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (15, V)) or Shift_Left (Slot (Val), V);
+ S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V);
end Set_4_Bit_Val;
procedure Set_8_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit)
is
- L : constant Field_Offset := Slot_Size / 8;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 8;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ Ptr : constant Slot_Ptr := Get_Slot_Ptr (N, Slot_Off);
+ S : Slot renames Ptr.all;
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (255, V)) or Shift_Left (Slot (Val), V);
+ S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V);
end Set_8_Bit_Val;
procedure Set_32_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit)
is
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ F_Size : constant := 32;
+ -- No Mask needed
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ Ptr : constant Slot_Ptr := Get_Slot_Ptr (N, Slot_Off);
+ S : Slot renames Ptr.all;
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
S := Slot (Val);
end Set_32_Bit_Val;
+ ----------------------
+ -- Print_Atree_Info --
+ ----------------------
+
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
+ function Cast is new Unchecked_Conversion (Slot, Int);
+ begin
+ Write_Int (Int (Size_In_Slots (N)));
+ Write_Str (" slots (");
+ Write_Int (Int (Off_0 (N)));
+ Write_Str (" .. ");
+ Write_Int (Int (Off_L (N)));
+ Write_Str ("):");
+
+ for Off in Off_0 (N) .. Off_L (N) loop
+ Write_Str (" ");
+ Write_Int (Cast (Get_Slot (N, Off)));
+ end loop;
+
+ Write_Eol;
+ end Print_Atree_Info;
+
end Atree_Private_Part;
---------------
-- etc.
function Get_Field_Value
- (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit
is
- pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
- Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
+ Desc : Seinfo.Field_Descriptor renames Field_Descriptors (Field);
begin
- case Field_Size (Desc.Kind) is
+ case Seinfo.Field_Size (Desc.Kind) is
when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
end Get_Field_Value;
procedure Set_Field_Value
- (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit)
+ (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit)
is
- pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
- Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
+ Desc : Seinfo.Field_Descriptor renames Field_Descriptors (Field);
begin
- case Field_Size (Desc.Kind) is
+ case Seinfo.Field_Size (Desc.Kind) is
when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val));
when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val));
when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val));
end case;
end Set_Field_Value;
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Node_Or_Entity_Field)
+ is
begin
Set_Field_Value (N, Field, 0);
end Reinit_Field_To_Zero;
function Field_Is_Initial_Zero
- (N : Node_Id; Field : Node_Field) return Boolean is
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean is
begin
return Get_Field_Value (N, Field) = 0;
end Field_Is_Initial_Zero;
end loop;
end Check_Vanishing_Fields;
- function Get_Field_Value
- (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit
- is
- pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
- Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
- begin
- case Field_Size (Desc.Kind) is
- when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
- when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
- when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
- when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
- when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32
- end case;
- end Get_Field_Value;
-
- procedure Set_Field_Value
- (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit)
- is
- pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
- Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
- begin
- case Field_Size (Desc.Kind) is
- when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val));
- when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val));
- when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val));
- when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val));
- when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32
- end case;
- end Set_Field_Value;
-
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is
- begin
- Set_Field_Value (N, Field, 0);
- end Reinit_Field_To_Zero;
-
- function Field_Is_Initial_Zero
- (N : Entity_Id; Field : Entity_Field) return Boolean is
- begin
- return Get_Field_Value (N, Field) = 0;
- end Field_Is_Initial_Zero;
-
procedure Check_Vanishing_Fields
(Old_N : Entity_Id; New_Kind : Entity_Kind)
is
end Check_Vanishing_Fields;
Nkind_Offset : constant Field_Offset :=
- Node_Field_Descriptors (F_Nkind).Offset;
+ Field_Descriptors (F_Nkind).Offset;
procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline;
if Old_Size < New_Size then
declare
Old_Last_Slot : constant Node_Offset := Slots.Last;
- Old_Off_0 : constant Node_Offset := Off_0 (N);
+ Old_Off_F : constant Node_Offset := Off_F (N);
begin
- if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then
+ if Old_Last_Slot = Old_Off_F + Old_Size - 1 then
-- In this case, the slots are at the end of Slots.Table, so we
-- don't need to move them.
Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size);
else
-- Move the slots
- All_Node_Offsets (N) := Alloc_Slots (New_Size);
- Copy_Slots (Old_Off_0, Off_0 (N), Old_Size);
- pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1));
+
+ declare
+ New_Off_F : constant Node_Offset := Alloc_Slots (New_Size);
+ begin
+ All_Node_Offsets (N).Offset := New_Off_F - Seinfo.N_Head;
+ Copy_Dynamic_Slots (Old_Off_F, New_Off_F, Old_Size);
+ pragma Debug
+ (Zero_Dynamic_Slots (Old_Off_F, Old_Off_F + Old_Size - 1));
+ end;
end if;
end;
- Zero_Slots (Off_0 (N) + Old_Size, Slots.Last);
+ Zero_Dynamic_Slots (Off_F (N) + Old_Size, Slots.Last);
end if;
Set_Node_Kind_Type (N, Nkind_Offset, Val);
pragma Debug (Validate_Node_Write (N));
+
+ New_Node_Debugging_Output (N);
end Mutate_Nkind;
procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is
begin
- Mutate_Nkind (N, Val, Old_Size => Size_In_Slots (N));
+ Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N));
end Mutate_Nkind;
Ekind_Offset : constant Field_Offset :=
- Entity_Field_Descriptors (F_Ekind).Offset;
+ Field_Descriptors (F_Ekind).Offset;
procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind)
with Inline;
Set_Entity_Kind_Type (N, Ekind_Offset, Val);
pragma Debug (Validate_Node_Write (N));
+
+ New_Node_Debugging_Output (N);
end Mutate_Ekind;
-----------------------
Sz : constant Slot_Count := Size_In_Slots_To_Alloc (Kind);
Sl : constant Node_Offset := Alloc_Slots (Sz);
begin
- Node_Offsets.Table (Result) := Sl;
- Zero_Slots (Sl, Sl + Sz - 1);
+ Node_Offsets.Table (Result).Offset := Sl - Seinfo.N_Head;
+ Zero_Dynamic_Slots (Sl, Sl + Sz - 1);
+ Zero_Header_Slots (Result);
end;
Init_Nkind (Result, Kind);
pragma Assert (Nkind (N) not in N_Entity);
pragma Assert (New_Kind not in N_Entity);
- Old_Size : constant Slot_Count := Size_In_Slots (N);
+ Old_Size : constant Slot_Count := Size_In_Slots_Dynamic (N);
New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (New_Kind);
Save_Sloc : constant Source_Ptr := Sloc (N);
New_Offset : constant Field_Offset := Alloc_Slots (New_Size);
begin
pragma Debug (Zero_Slots (N));
- Node_Offsets.Table (N) := New_Offset;
- Zero_Slots (New_Offset, New_Offset + New_Size - 1);
+ Node_Offsets.Table (N).Offset := New_Offset - Seinfo.N_Head;
+ Zero_Dynamic_Slots (New_Offset, New_Offset + New_Size - 1);
+ Zero_Header_Slots (N);
end;
else
Zero_Slots (N);
end if;
- Mutate_Nkind (N, New_Kind, Old_Size);
+ Init_Nkind (N, New_Kind); -- Not Mutate, because of Zero_Slots above
Set_Sloc (N, Save_Sloc);
Set_In_List (N, Save_In_List);
-- Copy_Slots --
----------------
- procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count) is
- pragma Assert (From /= To);
+ procedure Copy_Dynamic_Slots
+ (From, To : Node_Offset; Num_Slots : Slot_Count)
+ is
+ pragma Assert (if Num_Slots /= 0 then From /= To);
All_Slots : Slots.Table_Type renames
Slots.Table (Slots.First .. Slots.Last);
begin
Destination_Slots := Source_Slots;
- end Copy_Slots;
+ end Copy_Dynamic_Slots;
procedure Copy_Slots (Source, Destination : Node_Id) is
pragma Debug (Validate_Node (Source));
- pragma Debug (Validate_Node_Write (Destination));
pragma Assert (Source /= Destination);
- S_Size : constant Slot_Count := Size_In_Slots (Source);
+ S_Size : constant Slot_Count := Size_In_Slots_Dynamic (Source);
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- Copy_Slots
- (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size);
+ Copy_Dynamic_Slots
+ (Off_F (Source), Off_F (Destination), S_Size);
+ All_Node_Offsets (Destination).Slots := All_Node_Offsets (Source).Slots;
end Copy_Slots;
---------------
if D_Size < S_Size then
pragma Debug (Zero_Slots (Destination)); -- destroy old slots
- Node_Offsets.Table (Destination) := Alloc_Slots (S_Size);
+ Node_Offsets.Table (Destination).Offset :=
+ Alloc_Slots (S_Size) - Seinfo.N_Head;
end if;
Copy_Slots (Source, Destination);
Set_In_List (Destination, Save_In_List);
Set_Link (Destination, Save_Link);
-
Set_Paren_Count_Of_Copy (Target => Destination, Source => Source);
end Copy_Node;
(Is_Entity (E1) and then Is_Entity (E2)
and then not In_List (E1) and then not In_List (E2));
- Old_E1 : constant Node_Offset := Node_Offsets.Table (E1);
+ Old_E1 : constant Seinfo.Node_Header := Node_Offsets.Table (E1);
begin
Node_Offsets.Table (E1) := Node_Offsets.Table (E2);
pragma Assert (not Is_Entity (Source));
Old_Kind : constant Node_Kind := Nkind (Source);
+ pragma Assert (Old_Kind in N_Direct_Name);
New_Kind : constant Node_Kind :=
(case Old_Kind is
when N_Character_Literal => N_Defining_Character_Literal,
begin
for J in Fields'Range loop
declare
+ use Seinfo;
Desc : Field_Descriptor renames
- Node_Field_Descriptors (Fields (J));
+ Field_Descriptors (Fields (J));
begin
if Desc.Kind in Node_Id_Field | List_Id_Field then
Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset));
end if;
return New_Id : constant Node_Id := Alloc_Node_Id do
- Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size);
+ Node_Offsets.Table (New_Id).Offset :=
+ Alloc_Slots (S_Size) - Seinfo.N_Head;
Orig_Nodes.Append (New_Id);
Copy_Slots (Source, New_Id);
-- source nodes, then reset Current_Error_Node. This is useful
-- if we bomb during parsing to get a error location for the bomb.
- if New_Sloc > No_Location and then Comes_From_Source_Default then
+ if New_Sloc > No_Location and then Comes_From_Source_Default then
Current_Error_Node := New_Id;
end if;
-- Off_0 --
-----------
- function Off_0 (N : Node_Id) return Node_Offset is
+ function Off_0 (N : Node_Id) return Node_Offset'Base is
pragma Debug (Validate_Node (N));
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- return All_Node_Offsets (N);
+ return All_Node_Offsets (N).Offset;
end Off_0;
-----------
+ -- Off_F --
+ -----------
+
+ function Off_F (N : Node_Id) return Node_Offset is
+ begin
+ return Off_0 (N) + Seinfo.N_Head;
+ end Off_F;
+
+ -----------
-- Off_L --
-----------
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- return All_Node_Offsets (N) + Size_In_Slots (N) - 1;
+ return All_Node_Offsets (N).Offset + Size_In_Slots (N) - 1;
end Off_L;
-------------------
Set_Comes_From_Source (NewN, Comes_From_Source (OldN));
end Preserve_Comes_From_Source;
- ----------------------
- -- Print_Atree_Info --
- ----------------------
-
- procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
- function Cast is new Unchecked_Conversion (Slot, Int);
- begin
- Write_Int (Int (Size_In_Slots (N)));
- Write_Str (" slots (");
- Write_Int (Int (Off_0 (N)));
- Write_Str (" .. ");
- Write_Int (Int (Off_L (N)));
- Write_Str ("):");
-
- for Off in Off_0 (N) .. Off_L (N) loop
- Write_Str (" ");
- Write_Int (Cast (Slots.Table (Off)));
- end loop;
-
- Write_Eol;
- end Print_Atree_Info;
-
-------------------
-- Relocate_Node --
-------------------
procedure Destroy_New_Node is
begin
Zero_Slots (New_Node);
- Node_Offsets.Table (New_Node) := Field_Offset'Base'Last;
+ Node_Offsets.Table (New_Node).Offset := Field_Offset'Base'Last;
end Destroy_New_Node;
begin
Rewriting_Proc := Proc;
end Set_Rewriting_Proc;
+ ----------------------------
+ -- Size_In_Slots_To_Alloc --
+ ----------------------------
+
function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
begin
return
(if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
- else Sinfo.Nodes.Size (Kind));
+ else Sinfo.Nodes.Size (Kind)) - Seinfo.N_Head;
-- Unfortunately, we don't know the Entity_Kind, so we have to use the
-- max.
end Size_In_Slots_To_Alloc;
return Size_In_Slots_To_Alloc (Nkind (N));
end Size_In_Slots_To_Alloc;
+ -------------------
+ -- Size_In_Slots --
+ -------------------
+
function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
begin
pragma Assert (Nkind (N) /= N_Unused_At_Start);
else Sinfo.Nodes.Size (Nkind (N)));
end Size_In_Slots;
+ ---------------------------
+ -- Size_In_Slots_Dynamic --
+ ---------------------------
+
+ function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is
+ begin
+ return Size_In_Slots (N) - Seinfo.N_Head;
+ end Size_In_Slots_Dynamic;
+
-------------------
-- Traverse_Func --
-------------------
-- Zero_Slots --
----------------
- procedure Zero_Slots (First, Last : Node_Offset) is
+ procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is
begin
Slots.Table (First .. Last) := (others => 0);
- end Zero_Slots;
+ end Zero_Dynamic_Slots;
+
+ procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ All_Node_Offsets (N).Slots := (others => 0);
+ end Zero_Header_Slots;
procedure Zero_Slots (N : Node_Or_Entity_Id) is
begin
- Zero_Slots (Off_0 (N), Off_L (N));
+ Zero_Dynamic_Slots (Off_F (N), Off_L (N));
+ Zero_Header_Slots (N);
end Zero_Slots;
end Atree;
with Sinfo.Nodes; use Sinfo.Nodes;
with Einfo.Entities; use Einfo.Entities;
with Types; use Types;
+with Seinfo;
with System; use System;
with Table;
with Unchecked_Conversion;
type Entity_Field_Set is array (Entity_Field) of Boolean with Pack;
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field);
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field);
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Or_Entity_Field);
-- When a node is created, all fields are initialized to zero, even if zero
- -- is not a valid value of the field type. These procedures put the field
+ -- is not a valid value of the field type. This procedure puts the field
-- back to its initial zero value. Note that you can't just do something
-- like Set_Some_Field (N, 0), if Some_Field is of (say) type Uintp,
-- because Uintp is a subrange that does not include 0.
-- this.
function Field_Is_Initial_Zero
- (N : Node_Id; Field : Node_Field) return Boolean;
- function Field_Is_Initial_Zero
- (N : Entity_Id; Field : Entity_Field) return Boolean;
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean;
-- True if the field value is the initial zero value
procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) with Inline;
-- always the same; for example we change from E_Void, to E_Variable, to
-- E_Void, to E_Constant.
- procedure Print_Atree_Info (N : Node_Or_Entity_Id);
- -- Called from Treepr to print out information about N that is private to
- -- Atree.
-
-----------------------------
-- Private Part Subpackage --
-----------------------------
-- The nodes of the tree are stored in two tables (i.e. growable
-- arrays).
- -- A Node_Id points to an element of Nodes, which contains a
+ -- A Node_Id points to an element of Node_Offsets, which contains a
-- Field_Offset that points to an element of Slots. Each slot can
-- contain a single 32-bit field, or multiple smaller fields.
-- An n-bit field is aligned on an n-bit boundary. The size of a node is
-- The reason for the extra level of indirection is that Copy_Node,
-- Exchange_Entities, and Rewrite all assume that nodes can be modified
-- in place.
-
- subtype Node_Offset is Field_Offset'Base
- range 1 .. Field_Offset'Base'Last;
+ --
+ -- As an optimization, we store a few slots directly in the Node_Offsets
+ -- table (see type Node_Header) rather than requiring the extra level of
+ -- indirection for accessing those slots. N_Head is the number of slots
+ -- stored in the Node_Header. N_Head can be adjusted by modifying
+ -- Gen_IL.Gen. If N_Head is (say) 3, then a node containing 7 slots will
+ -- have slots 0..2 in the header, and 3..6 stored indirect in the Slots
+ -- table. We use zero-origin addressing, so the Offset into the Slots
+ -- table will point 3 slots before slot 3.
+
+ pragma Assert (Seinfo.N_Head <= Min_Node_Size);
+ pragma Assert (Seinfo.N_Head <= Min_Entity_Size);
package Node_Offsets is new Table.Table
- (Table_Component_Type => Node_Offset,
+ (Table_Component_Type => Seinfo.Node_Header,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Node_Offsets_Initial,
-- Short names for use in gdb, not used in real code. Note that gdb
-- can't find Node_Offsets.Table without a full expanded name.
- -- We define the type Slot as a 32-bit modular integer. It is logically
- -- split into the appropriate numbers of components of appropriate size,
- -- but this splitting is not explicit because packed arrays cannot be
- -- properly interfaced in C/C++ and packed records are way too slow.
-
- Slot_Size : constant := 32;
- type Slot is mod 2**Slot_Size;
- for Slot'Size use Slot_Size;
+ -- The type Slot is defined in Types as a 32-bit modular integer. It
+ -- is logically split into the appropriate numbers of components of
+ -- appropriate size, but this splitting is not explicit because packed
+ -- arrays cannot be properly interfaced in C/C++ and packed records are
+ -- way too slow.
function Shift_Left (S : Slot; V : Natural) return Slot;
pragma Import (Intrinsic, Shift_Left);
function Is_Valid_Node (U : Union_Id) return Boolean;
-- True if U is within the range of Node_Offsets
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id);
+ -- Called from Treepr to print out information about N that is private
+ -- to Atree.
+
end Atree_Private_Part;
end Atree;
#define Current_Error_Node atree__current_error_node
extern Node_Id Current_Error_Node;
-/* The following code corresponds to the Get_n_Bit_Field functions (for
- various n) in package Atree. The low-level getters in sinfo.h call
- these even-lower-level getters. */
-
-extern Field_Offset *Node_Offsets_Ptr;
-extern any_slot *Slots_Ptr;
-
-INLINE unsigned int Get_1_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_2_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_4_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_8_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_32_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_32_Bit_Field_With_Default (Node_Id, Field_Offset,
- unsigned int);
-INLINE unsigned int Get_Valid_32_Bit_Field (Node_Id, Field_Offset);
-
-INLINE unsigned int
-Get_1_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 1;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 1;
-}
-
-INLINE unsigned int
-Get_2_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 2;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 3;
-}
-
-INLINE unsigned int
-Get_4_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 4;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 15;
-}
-
-INLINE unsigned int
-Get_8_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 8;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 255;
-}
-
-INLINE unsigned int
-Get_32_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- return slot;
-}
-
-INLINE unsigned int
-Get_32_Bit_Field_With_Default (Node_Id N, Field_Offset Offset,
- unsigned int Default_Value)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- return slot == Empty ? Default_Value : slot;
-}
-
-INLINE unsigned int
-Get_Valid_32_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- gcc_assert (slot != Empty);
- return slot;
-}
-
#ifdef __cplusplus
}
#endif
function Known_Alignment (E : Entity_Id) return B is
begin
- return not Field_Is_Initial_Zero (E, F_Alignment);
+ -- For some reason, Empty is passed to this sometimes
+
+ return No (E) or else not Field_Is_Initial_Zero (E, F_Alignment);
end Known_Alignment;
procedure Reinit_Alignment (Id : E) is
#include "types.h"
#include "uintp.h"
#include "ada-tree.h"
+#include "sinfo.h"
#include "gigi.h"
/* Universal integers are represented by the Uint type which is an index into
extern void gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name,
- Field_Offset *node_offsets_ptr,
+ Node_Header *node_offsets_ptr,
any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
#include "ada.h"
#include "types.h"
#include "ada-tree.h"
+#include "sinfo.h"
#include "gigi.h"
/* If we don't have a specific size for Ada's equivalent of `long', use that
#define ALLOCA_THRESHOLD 1000
/* Pointers to front-end tables accessed through macros. */
-Field_Offset *Node_Offsets_Ptr;
+Node_Header *Node_Offsets_Ptr;
any_slot *Slots_Ptr;
Node_Id *Next_Node_Ptr;
Node_Id *Prev_Node_Ptr;
gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name ATTRIBUTE_UNUSED,
- Field_Offset *node_offsets_ptr,
+ Node_Header *node_offsets_ptr,
any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
package body Gen_IL.Gen is
+ Num_Header_Slots : constant := 3;
+ -- Number of header slots; the first Num_Header_Slots slots are stored in
+ -- the header; the rest are dynamically allocated in the Slots table. We
+ -- need to subtract this off when accessing dynamic slots. The constant
+ -- Seinfo.N_Head will contain this value.
+ --
+ -- This number can be adjusted for efficiency. We choose 3 because the
+ -- minimum node size is 3 slots, and because that causes the size of type
+ -- Node_Header to be a power of 2. We can't make it zero, however, because
+ -- C doesn't allow zero-length arrays.
+
+ N_Head : constant String := Image (Field_Offset'(Num_Header_Slots));
+ -- String form of the above
+
Enable_Assertions : constant Boolean := True;
-- True to enable predicates on the _Id types, and preconditions on getters
-- and setters.
-- which results in enormous nodes. For experimenting and debugging.
-- Should be True in normal operation, for efficiency.
+ SS : constant := 32; -- slot size in bits
+ SSS : constant String := Image (Bit_Offset'(SS));
+
Inline : constant String := "Inline";
-- For experimenting with Inline_Always
procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Setter_Locals
+ (S : in out Sink; F : Field_Enum; Get : Boolean);
procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
-- Print out the specification, declaration, or body of a getter or
-- Print out the precondition, if any, for a getter or setter for the
-- given field.
- procedure Put_Low_Level_Accessor_Instantiations
+ procedure Put_Casts
(S : in out Sink; T : Type_Enum);
- -- Print out the low-level getter and setter for a given type
+ -- Print out the Cast functions for a given type
procedure Put_Traversed_Fields (S : in out Sink);
-- Called by Put_Nodes to print out the Traversed_Fields table in
-- corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
-- thereof.
- procedure Put_Low_Level_C_Getter
- (S : in out Sink; T : Type_Enum);
- -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out low-level
- -- getters.
-
- procedure Put_High_Level_C_Getters
+ procedure Put_C_Getters
(S : in out Sink; Root : Root_Type);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
-- getters.
- procedure Put_High_Level_C_Getter
+ procedure Put_C_Getter
(S : in out Sink; F : Field_Enum);
- -- Used by Put_High_Level_C_Getters to print out one high-level getter.
+ -- Used by Put_C_Getters to print out one high-level getter.
procedure Put_Union_Membership
(S : in out Sink; Root : Root_Type);
function To_Size_In_Slots (Size_In_Bits : Bit_Offset)
return Field_Offset is
- ((Field_Offset (Size_In_Bits) + 31) / 32);
+ ((Field_Offset (Size_In_Bits) + (SS - 1)) / SS);
function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is
(To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary
function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is
- (Bit_Offset (Type_Size_In_Slots (T)) * 32); -- multiple of slot size
+ (Bit_Offset (Type_Size_In_Slots (T)) * SS); -- multiple of slot size
---------------------------
-- Compute_Field_Offsets --
end if;
end loop;
- Type_Bit_Size (T) := Max_Offset + 1;
+ -- No type can be smaller than the header slots
+
+ Type_Bit_Size (T) :=
+ Bit_Offset'Max (Max_Offset + 1, SS * Num_Header_Slots);
end;
end loop;
(if Setter_Needs_Parent (F) then "_With_Parent" else ""));
-------------------------------------------
- -- Put_Low_Level_Accessor_Instantiations --
+ -- Put_Casts --
-------------------------------------------
- procedure Put_Low_Level_Accessor_Instantiations
+ procedure Put_Casts
(S : in out Sink; T : Type_Enum)
is
+ Pre : constant String :=
+ "function Cast is new Unchecked_Conversion (";
+ Lo_Type : constant String := "Field_Size_" & Image (Field_Size (T)) & "_Bit";
+ Hi_Type : constant String := Get_Set_Id_Image (T);
begin
- -- Special case for subtypes of Uint that have predicates. Use
- -- Get_Valid_32_Bit_Field in that case.
-
- if T in Uint_Subtype then
- pragma Assert (Field_Size (T) = 32);
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_Valid_32_Bit_Field (" &
- Get_Set_Id_Image (T) &
- ") with " & Inline & ";" & LF);
-
- -- Special case for types that have special defaults; instantiate
- -- Get_32_Bit_Field_With_Default and pass in the Default_Val.
-
- elsif Field_Has_Special_Default (T) then
- pragma Assert (Field_Size (T) = 32);
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_32_Bit_Field_With_Default (" &
- Get_Set_Id_Image (T) & ", " & Special_Default (T) &
- ") with " & Inline & ";" & LF);
-
- -- Otherwise, instantiate the normal getter for the right size in
- -- bits.
-
- else
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_" & Image (Field_Size (T)) & "_Bit_Field (" &
- Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF);
- end if;
-
- if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (Off);" & LF);
- -- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called
- end if;
-
- -- No special cases for the setter
-
- Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" &
- Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
- ") with " & Inline & ";" & LF);
+ if T not in Uint_Subtype then
+ if T not in Node_Kind_Type | Entity_Kind_Type then
+ Put (S, Pre & Hi_Type & ", " & Lo_Type & ");" & LF);
+ end if;
- if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (On);" & LF);
+ Put (S, Pre & Lo_Type & ", " & Hi_Type & ");" & LF);
end if;
- end Put_Low_Level_Accessor_Instantiations;
+ end Put_Casts;
----------------------
-- Put_Precondition --
Put (S, ";" & LF);
end Put_Getter_Decl;
+ ------------------------------
+ -- Put_Getter_Setter_Locals --
+ ------------------------------
+
+ procedure Put_Getter_Setter_Locals
+ (S : in out Sink; F : Field_Enum; Get : Boolean)
+ is
+ Rec : Field_Info renames Field_Table (F).all;
+
+ Off : constant Field_Offset := Rec.Offset;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
+ F_Per_Slot : constant Field_Offset :=
+ SS / Field_Offset (Field_Size (Rec.Field_Type));
+ Slot_Off : constant Field_Offset := Off / F_Per_Slot;
+ In_NH : constant Boolean := Slot_Off < Num_Header_Slots;
+
+ N : constant String :=
+ (if Get then Node_To_Fetch_From (F) else "N");
+
+ begin
+ Put (S, " is" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "-- " & Image (F_Per_Slot) & " " & Image (F_Size) &
+ "-bit fields per " & SSS & "-bit slot." & LF);
+ Put (S, "-- Offset " & Image (Off) & " = " &
+ Image (Slot_Off) & " slots + " & Image (Off mod F_Per_Slot) &
+ " fields in slot." & LF & LF);
+
+ Put (S, "Off : constant := " & Image (Off) & ";" & LF);
+ Put (S, "F_Size : constant := " & Image (F_Size) & ";" & LF);
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "Mask : constant := 2**F_Size - 1;" & LF);
+ end if;
+
+ Put (S, "F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;" & LF);
+ Put (S, "Slot_Off : constant Field_Offset := Off / F_Per_Slot;" & LF);
+
+ if In_NH then
+ Put (S, "S : Slot renames Node_Offsets.Table (" & N & ").Slots (Slot_Off);" & LF);
+ else
+ Put (S, "S : Slot renames Slots.Table (Node_Offsets.Table (" & N & ").Offset + Slot_Off);" & LF);
+ end if;
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "V : constant Natural := Natural ((Off mod F_Per_Slot) * F_Size);" & LF);
+ Put (S, LF);
+ end if;
+ end Put_Getter_Setter_Locals;
+
---------------------
-- Put_Getter_Body --
---------------------
procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
+ T : constant String := Get_Set_Id_Image (Rec.Field_Type);
begin
-- Note that we store the result in a local constant below, so that
-- the "Pre => ..." can refer to it. The constant is called Val so
-- and setter.
Put_Getter_Spec (S, F);
- Put (S, " is" & LF);
- Increase_Indent (S, 3);
- Put (S, "Val : constant " & Get_Set_Id_Image (Rec.Field_Type) &
- " := " & Low_Level_Getter_Name (Rec.Field_Type) &
- " (" & Node_To_Fetch_From (F) & ", " &
- Image (Rec.Offset) & ");" & LF);
+ Put_Getter_Setter_Locals (S, F, Get => True);
+
+ Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit :=" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "Field_Size_" & Image (F_Size) & "_Bit (");
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "Shift_Right (S, V) and Mask);" & LF);
+ else
+ Put (S, "S);" & LF);
+ end if;
+
+ Decrease_Indent (S, 2);
+
+ Put (S, "Val : constant " & T & " :=");
+
+ if Field_Has_Special_Default (Rec.Field_Type) then
+ pragma Assert (Field_Size (Rec.Field_Type) = 32);
+ Put (S, LF);
+ Increase_Indent (S, 2);
+ Put (S, "(if Raw = 0 then " & Special_Default (Rec.Field_Type) & " else " & "Cast (Raw));");
+ Decrease_Indent (S, 2);
+
+ else
+ Put (S, " Cast (Raw);");
+ end if;
+
+ Put (S, LF);
+
Decrease_Indent (S, 3);
Put (S, "begin" & LF);
Increase_Indent (S, 3);
+ Put (S, "-- pragma Debug (Validate_Node_And_Offset (NN, Slot_Off));" & LF);
+ -- Comment out the validation, because it's too slow, and because the
+ -- relevant routines in Atree are not visible.
+
if Rec.Pre.all /= "" then
Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
-- If Type_Only was specified in the call to Create_Semantic_Field,
-- then we assert that the node is a base type. We cannot assert that
"Is_Base_Type (N)");
begin
Put_Setter_Spec (S, F);
- Put (S, " is" & LF);
+ Put_Getter_Setter_Locals (S, F, Get => False);
+
+ Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit := Cast (Val);" & LF);
+
+ Decrease_Indent (S, 3);
Put (S, "begin" & LF);
Increase_Indent (S, 3);
+ Put (S, "-- pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));" & LF);
+ -- Comment out the validation, because it's too slow, and because the
+ -- relevant routines in Atree are not visible.
+
if Rec.Pre.all /= "" then
Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
end if;
- Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset)
- & ", Val);" & LF);
+ if Setter_Needs_Parent (F) then
+ declare
+ Err : constant String :=
+ (if Rec.Field_Type = List_Id then "Error_List" else "Error");
+ begin
+ Put (S, "if Present (Val) and then Val /= " & Err & " then" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
+ Put (S, "Set_Parent (Val, N);" & LF);
+ Put (S, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end if;" & LF & LF);
+ end;
+ end if;
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Raw), V);" & LF);
+
+ else
+ Put (S, "S := Slot (Raw);" & LF);
+ end if;
+
Decrease_Indent (S, 3);
Put (S, "end Set_" & Image (F) & ";" & LF & LF);
end Put_Setter_Body;
when others => "Entity_Field"); -- Entity_Kind
begin
- Put (S, "-- Table of sizes in 32-bit slots for given " &
+ Put (S, "-- Table of sizes in " & SSS & "-bit slots for given " &
Image (Root) & ", for use by Atree:" & LF);
case Root is
Put (S, "); -- Size" & LF);
Decrease_Indent (S, 2);
- declare
- type Dummy is array
- (First_Field (Root) .. Last_Field (Root)) of Boolean;
- Num_Fields : constant Root_Int := Dummy'Length;
- First_Time : Boolean := True;
- begin
- Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
- & " fields:" & LF & LF);
+ if Root = Node_Kind then
+ declare
+ type Node_Dummy is array (Node_Field) of Boolean;
+ type Entity_Dummy is array (Entity_Field) of Boolean;
+ Num_Fields : constant Root_Int :=
+ Node_Dummy'Length + Entity_Dummy'Length;
+ First_Time : Boolean := True;
+ begin
+ Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
+ & " fields:" & LF & LF);
- Put (S, "type " & Field_Enum_Type_Name & " is" & LF);
- Increase_Indent (S, 2);
- Put (S, "(");
- Increase_Indent (S, 1);
+ Put (S, "type Node_Or_Entity_Field is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
- for F in First_Field (Root) .. Last_Field (Root) loop
- if First_Time then
- First_Time := False;
- else
+ for F in Node_Field loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, F_Image (F));
+ end loop;
+
+ for F in Entity_Field loop
Put (S, "," & LF);
- end if;
+ Put (S, F_Image (F));
+ end loop;
- Put (S, F_Image (F));
- end loop;
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Node_Or_Entity_Field" & LF);
+ Decrease_Indent (S, 2);
+ end;
+ end if;
- Decrease_Indent (S, 1);
- Put (S, "); -- " & Field_Enum_Type_Name & LF);
- Decrease_Indent (S, 2);
- end;
+ Put (S, LF & "subtype " & Field_Enum_Type_Name & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "Node_Or_Entity_Field range " & F_Image (First_Field (Root)) &
+ " .. " & F_Image (Last_Field (Root)) & ";" & LF);
+ Decrease_Indent (S, 2);
Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
Decrease_Indent (S, 2);
end;
- declare
- First_Time : Boolean := True;
- begin
- Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
+ if Root = Node_Kind then
+ declare
+ First_Time : Boolean := True;
+ begin
+ Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
- Put (S, Field_Enum_Type_Name & "_Descriptors : constant array (" &
- Field_Enum_Type_Name & ") of Field_Descriptor :=" & LF);
+ Put (S, "Field_Descriptors : constant array (" &
+ "Node_Or_Entity_Field) of Field_Descriptor :=" & LF);
- Increase_Indent (S, 2);
- Put (S, "(");
- Increase_Indent (S, 1);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
- for F in First_Field (Root) .. Last_Field (Root) loop
- if First_Time then
- First_Time := False;
- else
- Put (S, "," & LF);
- end if;
+ for F in Node_Field loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
- Put (S, F_Image (F) & " => (" &
- Image (Field_Table (F).Field_Type) & "_Field, " &
- Image (Field_Table (F).Offset) & ")");
- end loop;
+ Put (S, F_Image (F) & " => (" &
+ Image (Field_Table (F).Field_Type) & "_Field, " &
+ Image (Field_Table (F).Offset) & ")");
+ end loop;
- Decrease_Indent (S, 1);
- Put (S, "); -- Field_Descriptors" & LF);
- Decrease_Indent (S, 2);
- end;
+ for F in Entity_Field loop
+ Put (S, "," & LF);
+ Put (S, F_Image (F) & " => (" &
+ Image (Field_Table (F).Field_Type) & "_Field, " &
+ Image (Field_Table (F).Offset) & ")");
+ end loop;
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Field_Descriptors" & LF);
+ Decrease_Indent (S, 2);
+ end;
+ end if;
end Put_Tables;
Decrease_Indent (S, 3);
Put (S, "end record;" & LF);
+ -- Print out the node header types. Note that the Offset field is of
+ -- the base type, because we are using zero-origin addressing in
+ -- Atree.
+
+ Put (S, "N_Head : constant Field_Offset := " & N_Head & ";" & LF);
+ Put (S, "" & LF);
+ Put (S, "type Node_Header_Slots is" & LF);
+ Put (S, " array (Field_Offset range 0 .. N_Head - 1) of aliased Slot;" & LF);
+ Put (S, "type Node_Header is record" & LF);
+ Put (S, " Slots : Node_Header_Slots;" & LF);
+ Put (S, " Offset : Node_Offset'Base;" & LF);
+ Put (S, "end record;" & LF);
+ Put (S, "pragma Assert (Node_Header'Size = (" & N_Head &
+ " + 1) * " & SSS & ");" & LF);
+
Decrease_Indent (S, 3);
Put (S, LF & "end Seinfo;" & LF);
end Put_Seinfo;
S : Sink;
B : Sink;
- procedure Put_Setter_With_Parent (Kind : String);
- -- Put the low-level ..._With_Parent setter. Kind is either "Node" or
- -- "List".
-
- procedure Put_Setter_With_Parent (Kind : String) is
- Error : constant String := (if Kind = "Node" then "" else "_" & Kind);
- begin
- Put (B, LF & "procedure Set_" & Kind & "_Id_With_Parent" & LF);
- Increase_Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id);" & LF & LF);
- Decrease_Indent (B, 2);
-
- Put (B, "procedure Set_" & Kind & "_Id_With_Parent" & LF);
- Increase_Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id) is" & LF);
- Decrease_Indent (B, 2);
- Put (B, "begin" & LF);
- Increase_Indent (B, 3);
- Put (B, "if Present (Val) and then Val /= Error" & Error & " then" & LF);
- Increase_Indent (B, 3);
- Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
- Put (B, "Set_Parent (Val, N);" & LF);
- Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
- Decrease_Indent (B, 3);
- Put (B, "end if;" & LF & LF);
-
- Put (B, "Set_" & Kind & "_Id (N, Offset, Val);" & LF);
- Decrease_Indent (B, 3);
- Put (B, "end Set_" & Kind & "_Id_With_Parent;" & LF);
- end Put_Setter_With_Parent;
-
- -- Start of processing for Put_Nodes
-
begin
Create_File (S, "sinfo-nodes.ads");
Create_File (B, "sinfo-nodes.adb");
Decrease_Indent (S, 3);
Put (S, LF & "end Sinfo.Nodes;" & LF);
+ Put (B, "with Unchecked_Conversion;" & LF);
Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
Put (B, "with Nlists; use Nlists;" & LF);
Put (B, "pragma Warnings (Off);" & LF);
Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
- Put (B, "-- in units of the size of the field." & LF);
-
Put (B, "pragma Style_Checks (""M200"");" & LF);
+
for T in Special_Type loop
if Node_Field_Types_Used (T) then
- Put_Low_Level_Accessor_Instantiations (B, T);
+ Put_Casts (B, T);
end if;
end loop;
- Put_Setter_With_Parent ("Node");
- Put_Setter_With_Parent ("List");
-
Put_Subp_Bodies (B, Node_Kind);
Decrease_Indent (B, 3);
begin
Create_File (S, "einfo-entities.ads");
Create_File (B, "einfo-entities.adb");
- Put (S, "with Seinfo; use Seinfo;" & LF);
Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
Put (S, LF & "package Einfo.Entities is" & LF & LF);
Decrease_Indent (S, 3);
Put (S, LF & "end Einfo.Entities;" & LF);
+ Put (B, "with Unchecked_Conversion;" & LF);
Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
-- This forms a cycle between packages (via bodies, which is OK)
Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
- Put (B, "-- in units of the size of the field." & LF);
-
Put (B, "pragma Style_Checks (""M200"");" & LF);
+
for T in Special_Type loop
if Entity_Field_Types_Used (T) then
- Put_Low_Level_Accessor_Instantiations (B, T);
+ Put_Casts (B, T);
end if;
end loop;
return Result : Bit_Offset do
if F = No_Field then
-- We don't have a field size for No_Field, so just look at
- -- the bits up to the next word boundary.
+ -- the bits up to the next slot boundary.
Result := First_Bit;
- while (Result + 1) mod 32 /= 0
+ while (Result + 1) mod SS /= 0
and then Type_Layout (T) (Result + 1) = No_Field
loop
Result := Result + 1;
end Get_Last_Bit;
function First_Bit_Image (First_Bit : Bit_Offset) return String is
- W : constant Bit_Offset := First_Bit / 32;
- B : constant Bit_Offset := First_Bit mod 32;
- pragma Assert (W * 32 + B = First_Bit);
+ W : constant Bit_Offset := First_Bit / SS;
+ B : constant Bit_Offset := First_Bit mod SS;
+ pragma Assert (W * SS + B = First_Bit);
begin
return
- Image (W) & "*32" & (if B = 0 then "" else " + " & Image (B));
+ Image (W) & "*" & SSS & (if B = 0 then "" else " + " & Image (B));
end First_Bit_Image;
function Last_Bit_Image (Last_Bit : Bit_Offset) return String is
- W : constant Bit_Offset := (Last_Bit + 1) / 32;
+ W : constant Bit_Offset := (Last_Bit + 1) / SS;
begin
- if W * 32 - 1 = Last_Bit then
- return Image (W) & "*32 - 1";
+ if W * SS - 1 = Last_Bit then
+ return Image (W) & "*" & SSS & " - 1";
else
return First_Bit_Image (Last_Bit);
end if;
Put_Union_Membership (S, Root);
end Put_C_Type_And_Subtypes;
- ----------------------------
- -- Put_Low_Level_C_Getter --
- ----------------------------
+ ------------------
+ -- Put_C_Getter --
+ ------------------
- procedure Put_Low_Level_C_Getter
- (S : in out Sink; T : Type_Enum)
+ procedure Put_C_Getter
+ (S : in out Sink; F : Field_Enum)
is
- T_Image : constant String := Get_Set_Id_Image (T);
+ Rec : Field_Info renames Field_Table (F).all;
+
+ Off : constant Field_Offset := Rec.Offset;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
+ F_Per_Slot : constant Field_Offset :=
+ SS / Field_Offset (Field_Size (Rec.Field_Type));
+ Slot_Off : constant Field_Offset := Off / F_Per_Slot;
+ In_NH : constant Boolean := Slot_Off < Num_Header_Slots;
+ N : constant String := Node_To_Fetch_From (F);
begin
- Put (S, "INLINE " & T_Image & "" & LF);
- Put (S, "Get_" & Image (T) & " (Node_Id N, Field_Offset Offset)" & LF);
+ Put (S, "INLINE " & Get_Set_Id_Image (Rec.Field_Type) &
+ " " & Image (F) & " (Node_Id N)" & LF);
+ Put (S, "{" & LF);
Increase_Indent (S, 3);
+ Put (S, "const Field_Offset Off = " & Image (Rec.Offset) & ";" & LF);
+ Put (S, "const Field_Offset F_Size = " & Image (F_Size) & ";" & LF);
- -- Same special cases for getters as in
- -- Put_Low_Level_Accessor_Instantiations.
-
- if T in Uint_Subtype then
- pragma Assert (Field_Size (T) = 32);
- Put (S, "{ return (" & T_Image &
- ") Get_Valid_32_Bit_Field(N, Offset); }" & LF & LF);
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "const any_slot Mask = (1 << F_Size) - 1;" & LF);
+ end if;
- elsif Field_Has_Special_Default (T) then
- pragma Assert (Field_Size (T) = 32);
- Put (S, "{ return (" & T_Image &
- ") Get_32_Bit_Field_With_Default(N, Offset, " &
- Special_Default (T) & "); }" & LF & LF);
+ Put (S, "const Field_Offset F_Per_Slot = Slot_Size / F_Size;" & LF);
+ Put (S, "const Field_Offset Slot_Off = Off / F_Per_Slot;" & LF);
+ Put (S, LF);
+ if In_NH then
+ Put (S, "any_slot slot = Node_Offsets_Ptr[" & N & "].Slots[Slot_Off];" & LF);
+ else
+ Put (S, "any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[" & N &
+ "].Offset + Slot_Off);" & LF);
+ end if;
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "unsigned int Raw = (slot >> (Off % F_Per_Slot) * F_Size) & Mask;" & LF);
else
- Put (S, "{ return (" & T_Image & ") Get_" &
- Image (Field_Size (T)) & "_Bit_Field(N, Offset); }" & LF & LF);
+ Put (S, "unsigned int Raw = slot;" & LF);
end if;
- Decrease_Indent (S, 3);
- end Put_Low_Level_C_Getter;
+ Put (S, Get_Set_Id_Image (Rec.Field_Type) & " val = ");
- -----------------------------
- -- Put_High_Level_C_Getter --
- -----------------------------
+ if Field_Has_Special_Default (Rec.Field_Type) then
+ Increase_Indent (S, 2);
+ Put (S, "(Raw? Raw : " & Special_Default (Rec.Field_Type) & ")");
+ Decrease_Indent (S, 2);
- procedure Put_High_Level_C_Getter
- (S : in out Sink; F : Field_Enum)
- is
- begin
- Put (S, "INLINE " & Get_Set_Id_Image (Field_Table (F).Field_Type) &
- " " & Image (F) & " (Node_Id N)" & LF);
+ else
+ Put (S, "Raw");
+ end if;
- Increase_Indent (S, 3);
- Put (S, "{ return " &
- Low_Level_Getter_Name (Field_Table (F).Field_Type) &
- "(" & Node_To_Fetch_From (F) & ", " &
- Image (Field_Table (F).Offset) & "); }" & LF & LF);
+ Put (S, ";" & LF);
+
+ Put (S, "return val;" & LF);
Decrease_Indent (S, 3);
- end Put_High_Level_C_Getter;
+ Put (S, "}" & LF & LF);
+ end Put_C_Getter;
- ------------------------------
- -- Put_High_Level_C_Getters --
- ------------------------------
+ -------------------
+ -- Put_C_Getters --
+ -------------------
- procedure Put_High_Level_C_Getters
+ procedure Put_C_Getters
(S : in out Sink; Root : Root_Type)
is
begin
Put (S, "// Getters for fields" & LF & LF);
for F in First_Field (Root) .. Last_Field (Root) loop
- Put_High_Level_C_Getter (S, F);
+ Put_C_Getter (S, F);
end loop;
- end Put_High_Level_C_Getters;
+ end Put_C_Getters;
--------------------------
-- Put_Union_Membership --
Put (S, "typedef Boolean Flag;" & LF & LF);
+ Put (S, "#define N_Head " & N_Head & LF);
+ Put (S, "" & LF);
+ Put (S, "typedef struct Node_Header {" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "any_slot Slots[N_Head];" & LF);
+ Put (S, "Field_Offset Offset;" & LF);
+ Decrease_Indent (S, 2);
+ Put (S, "} Node_Header;" & LF & LF);
+
+ Put (S, "extern Node_Header *Node_Offsets_Ptr;" & LF);
+ Put (S, "extern any_slot *Slots_Ptr;" & LF & LF);
+
Put_C_Type_And_Subtypes (S, Node_Kind);
Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field"
& LF & LF);
- for T in Special_Type loop
- Put_Low_Level_C_Getter (S, T);
- end loop;
-
- Put_High_Level_C_Getters (S, Node_Kind);
+ Put_C_Getters (S, Node_Kind);
Put (S, "#ifdef __cplusplus" & LF);
Put (S, "}" & LF);
Put_C_Type_And_Subtypes (S, Entity_Kind);
- -- Note that we do not call Put_Low_Level_C_Getter here. Those are in
- -- sinfo.h, so every file that #includes einfo.h must #include
- -- sinfo.h first.
-
- Put_High_Level_C_Getters (S, Entity_Kind);
+ Put_C_Getters (S, Entity_Kind);
Put (S, "// Abstract type queries" & LF & LF);
-- any valuable per-node space and possibly results in better locality and
-- cache usage.
- type Name_Set is array (Node_Id range <>) of Boolean;
+ type Name_Set is array (Node_Id'Base range <>) of Boolean;
+ -- We use 'Base here, in case we want to add a predicate to Node_Id
pragma Pack (Name_Set);
function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
subtype CV_Range is Nat range 0 .. CV_Cache_Size;
type CV_Entry is record
- N : Node_Id;
+ N : Node_Id'Base;
+ -- We use 'Base here, in case we want to add a predicate to Node_Id
V : Uint;
end record;
-- The second method is much faster if the amount of Ada code being
-- compiled is large.
- ww : Node_Id'Base := Node_Id'First - 1;
+ ww : Node_Id'Base := Node_Low_Bound - 1;
pragma Export (Ada, ww);
Watch_Node : Node_Id'Base renames ww;
-- Node to "watch"; that is, whenever a node is created, we check if it
procedure nnd (N : Node_Id);
pragma Export (Ada, nnd);
- -- For debugging. If debugging is turned on, New_Node and New_Entity call
- -- this. If debug flag N is turned on, this prints out the new node.
+ -- For debugging. If debugging is turned on, New_Node and New_Entity (etc.)
+ -- call this. If debug flag N is turned on, this prints out the new node.
--
-- If Node = Watch_Node, this prints out the new node and calls
-- New_Node_Breakpoint. Otherwise, does nothing.
if Fields (J) /= F_Link then -- Don't walk Parent!
declare
Desc : Field_Descriptor renames
- Node_Field_Descriptors (Fields (J));
+ Field_Descriptors (Fields (J));
begin
if Is_In_Union_Id (Desc.Kind) then
Action (Get_Node_Field_Union (N, Desc.Offset));
if Fields (J) /= F_Link then -- Don't walk Parent!
declare
Desc : Field_Descriptor renames
- Node_Field_Descriptors (Fields (J));
+ Field_Descriptors (Fields (J));
begin
if Is_In_Union_Id (Desc.Kind) then
Set_Node_Field_Union
-- --
------------------------------------------------------------------------------
-with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Nodes; use Sinfo.Nodes;
package Sinfo.Utils is
-- mode parameters with scalar values.
type Table_Type is
- array (Table_Index_Type range <>) of Table_Component_Type;
+ array (Table_Index_Type range <>) of aliased Table_Component_Type;
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
procedure Capitalize (S : in out String);
-- Turns an identifier into Mixed_Case
- function Image (F : Node_Field) return String;
-
- function Image (F : Entity_Field) return String;
+ function Image (F : Node_Or_Entity_Field) return String;
procedure Print_Init;
-- Initialize for printing of tree with descendants
-- Image --
-----------
- function Image (F : Node_Field) return String is
+ function Image (F : Node_Or_Entity_Field) return String is
begin
case F is
when F_Alloc_For_BIP_Return =>
when F_TSS_Elist =>
return "TSS_Elist";
- when others =>
- declare
- Result : constant String := Capitalize (F'Img);
- begin
- return Result (3 .. Result'Last); -- Remove "F_"
- end;
- end case;
- end Image;
-
- function Image (F : Entity_Field) return String is
- begin
- case F is
when F_BIP_Initialization_Call =>
return "BIP_Initialization_Call";
when F_Body_Needed_For_SAL =>
for Field_Index in Fields'Range loop
declare
FD : Field_Descriptor renames
- Entity_Field_Descriptors (Fields (Field_Index));
+ Field_Descriptors (Fields (Field_Index));
begin
if Should_Print (Fields (Field_Index))
and then (FD.Kind = Flag_Field) = Print_Flags
-- Print Chars field if present
- if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
- Print_Str (Prefix);
- Print_Str ("Chars = ");
- Print_Name (Chars (N));
- Write_Str (" (Name_Id=");
- Write_Int (Int (Chars (N)));
- Write_Char (')');
- Print_Eol;
+ if Nkind (N) in N_Has_Chars then
+ if Field_Is_Initial_Zero (N, F_Chars) then
+ Print_Str (Prefix);
+ Print_Str ("Chars = initial zero");
+ Print_Eol;
+
+ elsif Chars (N) /= No_Name then
+ Print_Str (Prefix);
+ Print_Str ("Chars = ");
+ Print_Name (Chars (N));
+ Write_Str (" (Name_Id=");
+ Write_Int (Int (Chars (N)));
+ Write_Char (')');
+ Print_Eol;
+ end if;
end if;
-- Special field print operations for non-entity nodes
for Field_Index in Fields'Range loop
declare
FD : Field_Descriptor renames
- Node_Field_Descriptors (Fields (Field_Index));
+ Field_Descriptors (Fields (Field_Index));
begin
if Should_Print (Fields (Field_Index))
and then (FD.Kind = Flag_Field) = Print_Flags
if Nkind (N) in N_Has_Chars then
Write_Char (' ');
- Print_Name (Chars (N));
+
+ if Field_Is_Initial_Zero (N, F_Chars) then
+ Print_Str ("Chars = initial zero");
+ Print_Eol;
+
+ else
+ Print_Name (Chars (N));
+ end if;
end if;
if Nkind (N) in N_Entity then
for Field_Index in A'Range loop
declare
F : constant Node_Field := A (Field_Index);
- FD : Field_Descriptor renames Node_Field_Descriptors (F);
+ FD : Field_Descriptor renames Field_Descriptors (F);
begin
if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field
-- For all other kinds of descendants (strings, names, uints
for Field_Index in A'Range loop
declare
F : constant Entity_Field := A (Field_Index);
- FD : Field_Descriptor renames Entity_Field_Descriptors (F);
+ FD : Field_Descriptor renames Field_Descriptors (F);
begin
if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field
then
-- Offset of a node field, in units of the size of the field, which is
-- always a power of 2.
+ subtype Node_Offset is Field_Offset'Base range 1 .. Field_Offset'Base'Last;
+
subtype Slot_Count is Field_Offset;
-- Count of number of slots. Same type as Field_Offset to avoid
-- proliferation of type conversions.
type Offset_Array is
array (Offset_Array_Index range <>) of Opt_Field_Offset;
+ Slot_Size : constant := 32;
+ type Slot is mod 2**Slot_Size;
+ for Slot'Size use Slot_Size;
+
end Types;
projects / platform / upstream / gcc.git / commitdiff