diff options
| -rw-r--r-- | gcc/ada/atree.adb | 489 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/atree.h | 71 | ||||
| -rw-r--r-- | gcc/ada/einfo-utils.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/cuintp.c | 1 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/targtyps.c | 1 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 4 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen.adb | 548 | ||||
| -rw-r--r-- | gcc/ada/live.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sinfo-utils.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sinfo-utils.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/table.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/treepr.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 6 |
16 files changed, 691 insertions, 563 deletions
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index d69d403..00565d6 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -23,20 +23,12 @@ -- -- ------------------------------------------------------------------------------ --- 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; @@ -153,7 +145,11 @@ package body Atree is 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; @@ -161,35 +157,47 @@ package body Atree is -- 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. @@ -199,10 +207,6 @@ package body Atree is -- 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 @@ -405,7 +409,8 @@ package body Atree is 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); @@ -469,8 +474,9 @@ package body Atree is 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 @@ -480,8 +486,9 @@ package body Atree is 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 @@ -491,8 +498,9 @@ package body Atree is 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 @@ -502,8 +510,9 @@ package body Atree is 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 @@ -514,7 +523,8 @@ package body Atree is 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. @@ -612,133 +622,214 @@ package body Atree is 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; --------------- @@ -751,13 +842,12 @@ package body Atree is -- 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)); @@ -767,13 +857,12 @@ package body Atree is 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)); @@ -782,13 +871,15 @@ package body Atree is 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; @@ -839,47 +930,6 @@ package body Atree is 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 @@ -918,7 +968,7 @@ package body Atree 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; @@ -943,35 +993,43 @@ package body Atree is 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; @@ -993,6 +1051,8 @@ package body Atree is Set_Entity_Kind_Type (N, Ekind_Offset, Val); pragma Debug (Validate_Node_Write (N)); + + New_Node_Debugging_Output (N); end Mutate_Ekind; ----------------------- @@ -1006,8 +1066,9 @@ package body Atree is 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); @@ -1045,7 +1106,7 @@ package body Atree is 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); @@ -1068,15 +1129,16 @@ package body Atree is 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); @@ -1095,8 +1157,10 @@ package body Atree is -- 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); @@ -1109,21 +1173,21 @@ package body Atree is 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; --------------- @@ -1152,14 +1216,14 @@ package body Atree is 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; @@ -1371,7 +1435,7 @@ package body Atree is (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); @@ -1404,6 +1468,7 @@ package body Atree is 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, @@ -1469,8 +1534,9 @@ package body Atree is 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)); @@ -1620,7 +1686,8 @@ package body Atree is 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); @@ -1676,7 +1743,7 @@ package body Atree is -- 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; @@ -1765,16 +1832,25 @@ package body Atree is -- 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 -- ----------- @@ -1784,7 +1860,7 @@ package body Atree is 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; ------------------- @@ -1855,28 +1931,6 @@ package body Atree is 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 -- ------------------- @@ -1926,7 +1980,7 @@ package body Atree is 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 @@ -2182,11 +2236,15 @@ package body Atree is 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; @@ -2197,6 +2255,10 @@ package body Atree is 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); @@ -2205,6 +2267,15 @@ package body Atree is 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 -- ------------------- @@ -2372,14 +2443,22 @@ package body Atree is -- 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; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 94e589e..8836bb8 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -48,6 +48,7 @@ with Alloc; 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; @@ -566,10 +567,9 @@ package Atree is 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. @@ -583,9 +583,7 @@ package Atree is -- 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; @@ -611,10 +609,6 @@ package Atree is -- 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 -- ----------------------------- @@ -639,7 +633,7 @@ package Atree is -- 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 @@ -649,12 +643,21 @@ package Atree 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, @@ -668,14 +671,11 @@ package Atree is -- 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); @@ -856,6 +856,10 @@ package Atree is 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; diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 08b791c..7fb3bcb 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -65,77 +65,6 @@ Present (Tree_Id N) #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 diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 4e5f434..23e93c9 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -364,7 +364,9 @@ package body Einfo.Utils is 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 diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c index 6ac82d7..3488ae4 100644 --- a/gcc/ada/gcc-interface/cuintp.c +++ b/gcc/ada/gcc-interface/cuintp.c @@ -40,6 +40,7 @@ #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 diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 49b85a4..692ef44 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -234,7 +234,7 @@ extern "C" { 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, diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c index 704172d..6a3c0f2 100644 --- a/gcc/ada/gcc-interface/targtyps.c +++ b/gcc/ada/gcc-interface/targtyps.c @@ -35,6 +35,7 @@ #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 diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d3c421d..158bfe3 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -75,7 +75,7 @@ #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; @@ -279,7 +279,7 @@ void 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, diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 3bb9807..95fb526 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -28,6 +28,20 @@ with Ada.Text_IO; 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. @@ -37,6 +51,9 @@ package body Gen_IL.Gen is -- 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 @@ -563,6 +580,8 @@ package body Gen_IL.Gen is 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 @@ -573,9 +592,9 @@ package body Gen_IL.Gen is -- 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 @@ -616,19 +635,14 @@ package body Gen_IL.Gen is -- 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); @@ -884,13 +898,13 @@ package body Gen_IL.Gen is 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 -- @@ -1289,7 +1303,10 @@ package body Gen_IL.Gen is 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; @@ -1596,57 +1613,25 @@ package body Gen_IL.Gen is (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 -- @@ -1753,12 +1738,64 @@ package body Gen_IL.Gen is 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 @@ -1767,16 +1804,43 @@ package body Gen_IL.Gen is -- 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; @@ -1824,6 +1888,7 @@ package body Gen_IL.Gen is 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 @@ -1836,10 +1901,18 @@ package body Gen_IL.Gen is "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; @@ -1852,8 +1925,28 @@ package body Gen_IL.Gen is 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; @@ -2076,7 +2169,7 @@ package body Gen_IL.Gen is 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 @@ -2107,34 +2200,48 @@ package body Gen_IL.Gen 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 (" & @@ -2193,34 +2300,43 @@ package body Gen_IL.Gen is 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; @@ -2293,6 +2409,21 @@ package body Gen_IL.Gen is 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; @@ -2305,39 +2436,6 @@ package body Gen_IL.Gen is 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"); @@ -2369,6 +2467,7 @@ package body Gen_IL.Gen is 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); @@ -2381,19 +2480,14 @@ package body Gen_IL.Gen is 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); @@ -2411,7 +2505,6 @@ package body Gen_IL.Gen is 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); @@ -2430,6 +2523,7 @@ package body Gen_IL.Gen is 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) @@ -2439,13 +2533,11 @@ package body Gen_IL.Gen is 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; @@ -2714,11 +2806,11 @@ package body Gen_IL.Gen is 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; @@ -2731,19 +2823,19 @@ package body Gen_IL.Gen is 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; @@ -3027,76 +3119,84 @@ package body Gen_IL.Gen is 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 -- @@ -3174,16 +3274,24 @@ package body Gen_IL.Gen is 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); @@ -3238,11 +3346,7 @@ package body Gen_IL.Gen is 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); diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index 5a74f8b..db0a5f2 100644 --- a/gcc/ada/live.adb +++ b/gcc/ada/live.adb @@ -45,7 +45,8 @@ package body Live is -- 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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 6f81406..20bc03a 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -118,7 +118,8 @@ package body Sem_Eval is 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; diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 083c12e..55d0e40 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -55,7 +55,7 @@ package body Sinfo.Utils is -- 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 @@ -72,8 +72,8 @@ package body Sinfo.Utils is 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. @@ -265,7 +265,7 @@ package body Sinfo.Utils is 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)); @@ -290,7 +290,7 @@ package body Sinfo.Utils is 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 diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads index 2023e67..e3bb8d4 100644 --- a/gcc/ada/sinfo-utils.ads +++ b/gcc/ada/sinfo-utils.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Nodes; use Sinfo.Nodes; package Sinfo.Utils is diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index e934c27..07f2ae8 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -102,7 +102,7 @@ package Table 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); diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 48f76cb..4c7833b 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -130,9 +130,7 @@ package body Treepr is 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 @@ -281,7 +279,7 @@ package body Treepr is -- 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 => @@ -321,18 +319,6 @@ package body Treepr is 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 => @@ -666,7 +652,7 @@ package body Treepr is 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 @@ -1266,14 +1252,21 @@ package body Treepr is -- 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 @@ -1454,7 +1447,7 @@ package body Treepr is 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 @@ -1624,7 +1617,14 @@ package body Treepr is 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 @@ -2265,7 +2265,7 @@ package body Treepr is 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 @@ -2293,7 +2293,7 @@ package body Treepr is 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 diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 2caaf50..07b0960 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -991,6 +991,8 @@ package Types is -- 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. @@ -1005,4 +1007,8 @@ package Types is 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; |