1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 with Alloc; use Alloc;
36 with Atree; use Atree;
37 with Casing; use Casing;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
41 with Namet; use Namet;
43 with Output; use Output;
44 with Sinfo; use Sinfo;
45 with Sinput; use Sinput;
46 with Table; use Table;
47 with Uname; use Uname;
48 with Urealp; use Urealp;
50 package body Repinfo is
53 -- Value for Storage_Unit, we do not want to get this from TTypes, since
54 -- this introduces problematic dependencies in ASIS, and in any case this
55 -- value is assumed to be 8 for the implementation of the DDA.
56 -- This is wrong for AAMP???
58 ---------------------------------------
59 -- Representation of gcc Expressions --
60 ---------------------------------------
62 -- This table is used only if Frontend_Layout_On_Target is False,
63 -- so that gigi lays out dynamic size/offset fields using encoded
66 -- A table internal to this unit is used to hold the values of
67 -- back annotated expressions. This table is written out by -gnatt
68 -- and read back in for ASIS processing.
70 -- Node values are stored as Uint values which are the negative of
71 -- the node index in this table. Constants appear as non-negative
74 type Exp_Node is record
76 Op1 : Node_Ref_Or_Val;
77 Op2 : Node_Ref_Or_Val;
78 Op3 : Node_Ref_Or_Val;
81 package Rep_Table is new Table.Table (
82 Table_Component_Type => Exp_Node,
83 Table_Index_Type => Nat,
85 Table_Initial => Alloc.Rep_Table_Initial,
86 Table_Increment => Alloc.Rep_Table_Increment,
87 Table_Name => "BE_Rep_Table");
89 --------------------------------------------------------------
90 -- Representation of Front-End Dynamic Size/Offset Entities --
91 --------------------------------------------------------------
93 package Dynamic_SO_Entity_Table is new Table.Table (
94 Table_Component_Type => Entity_Id,
95 Table_Index_Type => Nat,
97 Table_Initial => Alloc.Rep_Table_Initial,
98 Table_Increment => Alloc.Rep_Table_Increment,
99 Table_Name => "FE_Rep_Table");
101 -----------------------
102 -- Local Subprograms --
103 -----------------------
105 Unit_Casing : Casing_Type;
106 -- Identifier casing for current unit
108 procedure Spaces (N : Natural);
109 -- Output given number of spaces
111 function Back_End_Layout return Boolean;
112 -- Test for layout mode, True = back end, False = front end. This
113 -- function is used rather than checking the configuration parameter
114 -- because we do not want Repinfo to depend on Targparm (for ASIS)
116 procedure List_Entities (Ent : Entity_Id);
117 -- This procedure lists the entities associated with the entity E,
118 -- starting with the First_Entity and using the Next_Entity link.
119 -- If a nested package is found, entities within the package are
120 -- recursively processed.
122 procedure List_Name (Ent : Entity_Id);
123 -- List name of entity Ent in appropriate case. The name is listed with
124 -- full qualification up to but not including the compilation unit name.
126 procedure List_Array_Info (Ent : Entity_Id);
127 -- List representation info for array type Ent
129 procedure List_Object_Info (Ent : Entity_Id);
130 -- List representation info for object Ent
132 procedure List_Record_Info (Ent : Entity_Id);
133 -- List representation info for record type Ent
135 procedure List_Type_Info (Ent : Entity_Id);
136 -- List type info for type Ent
138 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
139 -- Returns True if Val represents a variable value, and False if it
140 -- represents a value that is fixed at compile time.
142 procedure Write_Info_Line (S : String);
143 -- Routine to write a line to Repinfo output file. This routine is
144 -- passed as a special output procedure to Output.Set_Special_Output.
145 -- Note that Write_Info_Line is called with an EOL character at the
146 -- end of each line, as per the Output spec, but the internal call
147 -- to the appropriate routine in Osint requires that the end of line
148 -- sequence be stripped off.
150 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
151 -- Given a representation value, write it out. No_Uint values or values
152 -- dependent on discriminants are written as two question marks. If the
153 -- flag Paren is set, then the output is surrounded in parentheses if
154 -- it is other than a simple value.
156 ---------------------
157 -- Back_End_Layout --
158 ---------------------
160 function Back_End_Layout return Boolean is
162 -- We have back end layout if the back end has made any entries in
163 -- the table of GCC expressions, otherwise we have front end layout.
165 return Rep_Table.Last > 0;
168 ------------------------
169 -- Create_Discrim_Ref --
170 ------------------------
172 function Create_Discrim_Ref
176 N : constant Uint := Discriminant_Number (Discr);
180 Rep_Table.Increment_Last;
182 Rep_Table.Table (T).Expr := Discrim_Val;
183 Rep_Table.Table (T).Op1 := N;
184 Rep_Table.Table (T).Op2 := No_Uint;
185 Rep_Table.Table (T).Op3 := No_Uint;
186 return UI_From_Int (-T);
187 end Create_Discrim_Ref;
189 ---------------------------
190 -- Create_Dynamic_SO_Ref --
191 ---------------------------
193 function Create_Dynamic_SO_Ref
195 return Dynamic_SO_Ref
200 Dynamic_SO_Entity_Table.Increment_Last;
201 T := Dynamic_SO_Entity_Table.Last;
202 Dynamic_SO_Entity_Table.Table (T) := E;
203 return UI_From_Int (-T);
204 end Create_Dynamic_SO_Ref;
212 Op1 : Node_Ref_Or_Val;
213 Op2 : Node_Ref_Or_Val := No_Uint;
214 Op3 : Node_Ref_Or_Val := No_Uint)
220 Rep_Table.Increment_Last;
222 Rep_Table.Table (T).Expr := Expr;
223 Rep_Table.Table (T).Op1 := Op1;
224 Rep_Table.Table (T).Op2 := Op2;
225 Rep_Table.Table (T).Op3 := Op3;
227 return UI_From_Int (-T);
230 ---------------------------
231 -- Get_Dynamic_SO_Entity --
232 ---------------------------
234 function Get_Dynamic_SO_Entity
239 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
240 end Get_Dynamic_SO_Entity;
242 -----------------------
243 -- Is_Dynamic_SO_Ref --
244 -----------------------
246 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
249 end Is_Dynamic_SO_Ref;
251 ----------------------
252 -- Is_Static_SO_Ref --
253 ----------------------
255 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
258 end Is_Static_SO_Ref;
264 procedure lgx (U : Node_Ref_Or_Val) is
266 List_GCC_Expression (U);
270 ----------------------
271 -- List_Array_Info --
272 ----------------------
274 procedure List_Array_Info (Ent : Entity_Id) is
276 List_Type_Info (Ent);
280 Write_Str ("'Component_Size use ");
281 Write_Val (Component_Size (Ent));
289 procedure List_Entities (Ent : Entity_Id) is
293 if Present (Ent) then
294 E := First_Entity (Ent);
295 while Present (E) loop
297 -- We list entities that come from source (excluding private
298 -- types, where we will list the info for the full view). If
299 -- debug flag A is set, all entities are listed
301 if (Comes_From_Source (E) and then not Is_Private_Type (E))
302 or else Debug_Flag_AA
304 if Is_Record_Type (E) then
305 List_Record_Info (E);
307 elsif Is_Array_Type (E) then
310 elsif List_Representation_Info >= 2 then
314 elsif Ekind (E) = E_Variable
316 Ekind (E) = E_Constant
318 Ekind (E) = E_Loop_Parameter
322 List_Object_Info (E);
326 -- Recurse into nested package, but not if they are
327 -- package renamings (in particular renamings of the
328 -- enclosing package, as for some Java bindings and
329 -- for generic instances).
331 if Ekind (E) = E_Package then
332 if No (Renamed_Object (E)) then
336 -- Recurse into bodies
338 elsif Ekind (E) = E_Protected_Type
340 Ekind (E) = E_Task_Type
342 Ekind (E) = E_Subprogram_Body
344 Ekind (E) = E_Package_Body
346 Ekind (E) = E_Task_Body
348 Ekind (E) = E_Protected_Body
352 -- Recurse into blocks
354 elsif Ekind (E) = E_Block then
359 E := Next_Entity (E);
364 -------------------------
365 -- List_GCC_Expression --
366 -------------------------
368 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
370 procedure P (Val : Node_Ref_Or_Val);
371 -- Internal recursive procedure to print expression
373 procedure P (Val : Node_Ref_Or_Val) is
376 UI_Write (Val, Decimal);
380 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
382 procedure Binop (S : String);
383 -- Output text for binary operator with S being operator name
385 procedure Binop (S : String) is
394 -- Start of processing for P
401 Write_Str (" then ");
403 Write_Str (" else ");
416 when Trunc_Div_Expr =>
419 when Ceil_Div_Expr =>
422 when Floor_Div_Expr =>
425 when Trunc_Mod_Expr =>
428 when Floor_Mod_Expr =>
431 when Ceil_Mod_Expr =>
434 when Exact_Div_Expr =>
451 when Truth_Andif_Expr =>
454 when Truth_Orif_Expr =>
457 when Truth_And_Expr =>
460 when Truth_Or_Expr =>
463 when Truth_Xor_Expr =>
466 when Truth_Not_Expr =>
497 -- Start of processing for List_GCC_Expression
505 end List_GCC_Expression;
511 procedure List_Name (Ent : Entity_Id) is
513 if not Is_Compilation_Unit (Scope (Ent)) then
514 List_Name (Scope (Ent));
518 Get_Unqualified_Decoded_Name_String (Chars (Ent));
519 Set_Casing (Unit_Casing);
520 Write_Str (Name_Buffer (1 .. Name_Len));
523 ---------------------
524 -- List_Object_Info --
525 ---------------------
527 procedure List_Object_Info (Ent : Entity_Id) is
533 Write_Str ("'Size use ");
534 Write_Val (Esize (Ent));
539 Write_Str ("'Alignment use ");
540 Write_Val (Alignment (Ent));
542 end List_Object_Info;
544 ----------------------
545 -- List_Record_Info --
546 ----------------------
548 procedure List_Record_Info (Ent : Entity_Id) is
554 Max_Name_Length : Natural;
555 Max_Suni_Length : Natural;
558 List_Type_Info (Ent);
562 Write_Line (" use record");
564 -- First loop finds out max line length and max starting position
565 -- length, for the purpose of lining things up nicely.
567 Max_Name_Length := 0;
568 Max_Suni_Length := 0;
570 Comp := First_Entity (Ent);
571 while Present (Comp) loop
572 if Ekind (Comp) = E_Component
573 or else Ekind (Comp) = E_Discriminant
575 Get_Decoded_Name_String (Chars (Comp));
576 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
578 Cfbit := Component_Bit_Offset (Comp);
580 if Rep_Not_Constant (Cfbit) then
581 UI_Image_Length := 2;
584 -- Complete annotation in case not done
586 Set_Normalized_Position (Comp, Cfbit / SSU);
587 Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
589 Esiz := Esize (Comp);
590 Sunit := Cfbit / SSU;
594 -- If the record is not packed, then we know that all
595 -- fields whose position is not specified have a starting
596 -- normalized bit position of zero
598 if Unknown_Normalized_First_Bit (Comp)
599 and then not Is_Packed (Ent)
601 Set_Normalized_First_Bit (Comp, Uint_0);
605 Natural'Max (Max_Suni_Length, UI_Image_Length);
608 Comp := Next_Entity (Comp);
611 -- Second loop does actual output based on those values
613 Comp := First_Entity (Ent);
614 while Present (Comp) loop
615 if Ekind (Comp) = E_Component
616 or else Ekind (Comp) = E_Discriminant
619 Esiz : constant Uint := Esize (Comp);
620 Bofs : constant Uint := Component_Bit_Offset (Comp);
621 Npos : constant Uint := Normalized_Position (Comp);
622 Fbit : constant Uint := Normalized_First_Bit (Comp);
627 Get_Decoded_Name_String (Chars (Comp));
628 Set_Casing (Unit_Casing);
629 Write_Str (Name_Buffer (1 .. Name_Len));
631 for J in 1 .. Max_Name_Length - Name_Len loop
637 if Known_Static_Normalized_Position (Comp) then
639 Spaces (Max_Suni_Length - UI_Image_Length);
640 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
642 elsif Known_Component_Bit_Offset (Comp)
643 and then List_Representation_Info = 3
645 Spaces (Max_Suni_Length - 2);
646 Write_Str ("bit offset");
647 Write_Val (Bofs, Paren => True);
648 Write_Str (" size in bits = ");
649 Write_Val (Esiz, Paren => True);
653 elsif Known_Normalized_Position (Comp)
654 and then List_Representation_Info = 3
656 Spaces (Max_Suni_Length - 2);
660 -- For the packed case, we don't know the bit positions
661 -- if we don't know the starting position!
663 if Is_Packed (Ent) then
664 Write_Line ("?? range ? .. ??;");
667 -- Otherwise we can continue
674 Write_Str (" range ");
678 -- Allowing Uint_0 here is a kludge, really this should be
679 -- a fine Esize value but currently it means unknown, except
680 -- that we know after gigi has back annotated that a size of
681 -- zero is real, since otherwise gigi back annotates using
682 -- No_Uint as the value to indicate unknown).
684 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
685 and then Known_Static_Normalized_First_Bit (Comp)
687 Lbit := Fbit + Esiz - 1;
695 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
696 -- Officially a value of zero for Esize means unknown, but here
697 -- we use the fact that we know that gigi annotates Esize with
698 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
700 elsif List_Representation_Info < 3
701 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
705 else -- List_Representation >= 3 and Known_Esize (Comp)
707 Write_Val (Esiz, Paren => True);
709 -- If in front end layout mode, then dynamic size is
710 -- stored in storage units, so renormalize for output
712 if not Back_End_Layout then
717 -- Add appropriate first bit offset
727 Write_Int (UI_To_Int (Fbit) - 1);
736 Comp := Next_Entity (Comp);
739 Write_Line ("end record;");
740 end List_Record_Info;
746 procedure List_Rep_Info is
750 for U in Main_Unit .. Last_Unit loop
751 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
753 -- Normal case, list to standard output
755 if not List_Representation_Info_To_File then
756 Unit_Casing := Identifier_Casing (Source_Index (U));
758 Write_Str ("Representation information for unit ");
759 Write_Unit_Name (Unit_Name (U));
763 for J in 1 .. Col - 1 loop
768 List_Entities (Cunit_Entity (U));
770 -- List representation information to file
773 Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
774 Set_Special_Output (Write_Info_Line'Access);
775 List_Entities (Cunit_Entity (U));
776 Set_Special_Output (null);
777 Close_Repinfo_File_Access.all;
783 ---------------------
784 -- Write_Info_Line --
785 ---------------------
787 procedure Write_Info_Line (S : String) is
789 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
796 procedure List_Type_Info (Ent : Entity_Id) is
800 -- Do not list size info for unconstrained arrays, not meaningful
802 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
806 -- If Esize and RM_Size are the same and known, list as Size. This
807 -- is a common case, which we may as well list in simple form.
809 if Esize (Ent) = RM_Size (Ent) then
812 Write_Str ("'Size use ");
813 Write_Val (Esize (Ent));
816 -- For now, temporary case, to be removed when gigi properly back
817 -- annotates RM_Size, if RM_Size is not set, then list Esize as
818 -- Size. This avoids odd Object_Size output till we fix things???
820 elsif Unknown_RM_Size (Ent) then
823 Write_Str ("'Size use ");
824 Write_Val (Esize (Ent));
827 -- Otherwise list size values separately if they are set
832 Write_Str ("'Object_Size use ");
833 Write_Val (Esize (Ent));
836 -- Note on following check: The RM_Size of a discrete type can
837 -- legitimately be set to zero, so a special check is needed.
841 Write_Str ("'Value_Size use ");
842 Write_Val (RM_Size (Ent));
849 Write_Str ("'Alignment use ");
850 Write_Val (Alignment (Ent));
854 ----------------------
855 -- Rep_Not_Constant --
856 ----------------------
858 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
860 if Val = No_Uint or else Val < 0 then
865 end Rep_Not_Constant;
872 (Val : Node_Ref_Or_Val;
876 function B (Val : Boolean) return Uint;
877 -- Returns Uint_0 for False, Uint_1 for True
879 function T (Val : Node_Ref_Or_Val) return Boolean;
880 -- Returns True for 0, False for any non-zero (i.e. True)
882 function V (Val : Node_Ref_Or_Val) return Uint;
883 -- Internal recursive routine to evaluate tree
889 function B (Val : Boolean) return Uint is
902 function T (Val : Node_Ref_Or_Val) return Boolean is
915 function V (Val : Node_Ref_Or_Val) return Uint is
924 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
936 return V (Node.Op1) + V (Node.Op2);
939 return V (Node.Op1) - V (Node.Op2);
942 return V (Node.Op1) * V (Node.Op2);
944 when Trunc_Div_Expr =>
945 return V (Node.Op1) / V (Node.Op2);
947 when Ceil_Div_Expr =>
950 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
952 when Floor_Div_Expr =>
955 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
957 when Trunc_Mod_Expr =>
958 return V (Node.Op1) rem V (Node.Op2);
960 when Floor_Mod_Expr =>
961 return V (Node.Op1) mod V (Node.Op2);
963 when Ceil_Mod_Expr =>
966 Q := UR_Ceiling (L / UR_From_Uint (R));
969 when Exact_Div_Expr =>
970 return V (Node.Op1) / V (Node.Op2);
973 return -V (Node.Op1);
976 return UI_Min (V (Node.Op1), V (Node.Op2));
979 return UI_Max (V (Node.Op1), V (Node.Op2));
982 return UI_Abs (V (Node.Op1));
984 when Truth_Andif_Expr =>
985 return B (T (Node.Op1) and then T (Node.Op2));
987 when Truth_Orif_Expr =>
988 return B (T (Node.Op1) or else T (Node.Op2));
990 when Truth_And_Expr =>
991 return B (T (Node.Op1) and T (Node.Op2));
993 when Truth_Or_Expr =>
994 return B (T (Node.Op1) or T (Node.Op2));
996 when Truth_Xor_Expr =>
997 return B (T (Node.Op1) xor T (Node.Op2));
999 when Truth_Not_Expr =>
1000 return B (not T (Node.Op1));
1003 return B (V (Node.Op1) < V (Node.Op2));
1006 return B (V (Node.Op1) <= V (Node.Op2));
1009 return B (V (Node.Op1) > V (Node.Op2));
1012 return B (V (Node.Op1) >= V (Node.Op2));
1015 return B (V (Node.Op1) = V (Node.Op2));
1018 return B (V (Node.Op1) /= V (Node.Op2));
1022 Sub : constant Int := UI_To_Int (Node.Op1);
1025 pragma Assert (Sub in D'Range);
1034 -- Start of processing for Rep_Value
1037 if Val = No_Uint then
1049 procedure Spaces (N : Natural) is
1051 for J in 1 .. N loop
1060 procedure Tree_Read is
1062 Rep_Table.Tree_Read;
1069 procedure Tree_Write is
1071 Rep_Table.Tree_Write;
1078 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
1080 if Rep_Not_Constant (Val) then
1081 if List_Representation_Info < 3 or else Val = No_Uint then
1085 if Back_End_Layout then
1090 List_GCC_Expression (Val);
1093 List_GCC_Expression (Val);
1101 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1104 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));