| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G E N _ I L . G E N -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2020-2021, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Containers; use type Ada.Containers.Count_Type; |
| with Ada.Text_IO; |
| |
| package body Gen_IL.Gen is |
| |
| Enable_Assertions : constant Boolean := True; |
| -- True to enable predicates on the _Id types, and preconditions on getters |
| -- and setters. |
| |
| Overlay_Fields : constant Boolean := True; |
| -- False to allocate every field so it doesn't overlay any other fields, |
| -- which results in enormous nodes. For experimenting and debugging. |
| -- Should be True in normal operation, for efficiency. |
| |
| Inline : constant String := "Inline"; |
| -- For experimenting with Inline_Always |
| |
| Syntactic : Fields_Per_Node_Type := |
| (others => (others => False)); |
| |
| Nodes_And_Entities : constant Type_Vector := Node_Kind & Entity_Kind; |
| All_Entities : constant Type_Vector := To_Vector (Entity_Kind, Length => 1); |
| |
| procedure Create_Type |
| (T : Node_Or_Entity_Type; |
| Parent : Opt_Abstract_Type; |
| Fields : Field_Sequence; |
| Nmake_Assert : String); |
| -- Called by the Create_..._Type procedures exported by this package to |
| -- create an entry in the Types_Table. |
| |
| procedure Create_Union_Type |
| (Root : Root_Type; T : Abstract_Type; Children : Type_Array); |
| -- Called by Create_Node_Union_Type and Create_Entity_Union_Type to create |
| -- a union type. |
| |
| function Create_Field |
| (Field : Field_Enum; |
| Field_Type : Type_Enum; |
| Default_Value : Field_Default_Value; |
| Type_Only : Type_Only_Enum; |
| Pre, Pre_Get, Pre_Set : String; |
| Is_Syntactic : Boolean) return Field_Desc; |
| -- Called by the Create_..._Field functions exported by this package to |
| -- create an entry in the Field_Table. See Create_Syntactic_Field and |
| -- Create_Semantic_Field for additional doc. |
| |
| procedure Check_Type (T : Node_Or_Entity_Type); |
| -- Check some "legality" rules for types in the Gen_IL little language |
| |
| ---------------- |
| -- Check_Type -- |
| ---------------- |
| |
| procedure Check_Type (T : Node_Or_Entity_Type) is |
| Im : constant String := Node_Or_Entity_Type'Image (T); |
| begin |
| if Type_Table (T) /= null then |
| raise Illegal with "duplicate creation of type " & Image (T); |
| end if; |
| |
| if T not in Root_Type then |
| case T is |
| when Node_Type => |
| if Im'Length < 2 or else Im (1 .. 2) /= "N_" then |
| raise Illegal with "Node type names must start with ""N_"""; |
| end if; |
| |
| when Concrete_Entity => |
| if Im'Length < 2 or else Im (1 .. 2) /= "E_" then |
| raise Illegal with |
| "Concrete entity type names must start with ""E_"""; |
| end if; |
| |
| when others => null; |
| -- No special prefix for abstract entities |
| end case; |
| end if; |
| end Check_Type; |
| |
| ----------------- |
| -- Create_Type -- |
| ----------------- |
| |
| procedure Create_Type |
| (T : Node_Or_Entity_Type; |
| Parent : Opt_Abstract_Type; |
| Fields : Field_Sequence; |
| Nmake_Assert : String) |
| is |
| begin |
| Check_Type (T); |
| |
| if T not in Root_Type then |
| if Type_Table (Parent) = null then |
| raise Illegal with |
| "undefined parent type for " & |
| Image (T) & " (parent is " & Image (Parent) & ")"; |
| end if; |
| |
| if Type_Table (Parent).Is_Union then |
| raise Illegal with |
| "parent type for " & |
| Image (T) & " must not be union (" & Image (Parent) & ")"; |
| end if; |
| end if; |
| |
| Type_Table (T) := |
| new Type_Info' |
| (Is_Union => False, Parent => Parent, |
| Children | Concrete_Descendants => Type_Vectors.Empty_Vector, |
| First | Last | Fields => <>, -- filled in later |
| Nmake_Assert => new String'(Nmake_Assert)); |
| |
| if Parent /= No_Type then |
| Append (Type_Table (Parent).Children, T); |
| end if; |
| |
| -- Check that syntactic fields precede semantic fields. Note that this |
| -- check is happening before we compute inherited fields. |
| -- Exempt Chars and Actions from this rule, for now. |
| |
| declare |
| Semantic_Seen : Boolean := False; |
| begin |
| for J in Fields'Range loop |
| if Fields (J).Is_Syntactic then |
| if Semantic_Seen then |
| raise Illegal with |
| "syntactic fields must precede semantic ones " & Image (T); |
| end if; |
| |
| else |
| if Fields (J).F not in Chars | Actions then |
| Semantic_Seen := True; |
| end if; |
| end if; |
| end loop; |
| end; |
| |
| -- Check that node fields are in nodes, and entity fields are in |
| -- entities. |
| |
| for J in Fields'Range loop |
| declare |
| Field : constant Field_Enum := Fields (J).F; |
| Error_Prefix : constant String := |
| "Field " & Image (T) & "." & Image (Field) & " not in "; |
| begin |
| case T is |
| when Node_Type => |
| if Field not in Node_Field then |
| raise Illegal with Error_Prefix & "Node_Field"; |
| end if; |
| |
| when Entity_Type => |
| if Field not in Entity_Field then |
| raise Illegal with Error_Prefix & "Entity_Field"; |
| end if; |
| |
| when Type_Boundaries => |
| raise Program_Error; -- dummy types shouldn't have fields |
| end case; |
| end; |
| end loop; |
| |
| -- Compute the Have_This_Field component of fields, the Fields component |
| -- of the current type, and Syntactic table. |
| |
| for J in Fields'Range loop |
| declare |
| Field : constant Field_Enum := Fields (J).F; |
| Is_Syntactic : constant Boolean := Fields (J).Is_Syntactic; |
| |
| begin |
| Append (Field_Table (Field).Have_This_Field, T); |
| Append (Type_Table (T).Fields, Field); |
| |
| pragma Assert (not Syntactic (T) (Field)); |
| Syntactic (T) (Field) := Is_Syntactic; |
| end; |
| end loop; |
| end Create_Type; |
| |
| -- Other than constraint checks on T at the call site, and the lack of a |
| -- parent for root types, the following six all do the same thing. |
| |
| --------------------------- |
| -- Create_Root_Node_Type -- |
| --------------------------- |
| |
| procedure Create_Root_Node_Type |
| (T : Abstract_Node; |
| Fields : Field_Sequence := No_Fields) is |
| begin |
| Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => ""); |
| end Create_Root_Node_Type; |
| |
| ------------------------------- |
| -- Create_Abstract_Node_Type -- |
| ------------------------------- |
| |
| procedure Create_Abstract_Node_Type |
| (T : Abstract_Node; Parent : Abstract_Type; |
| Fields : Field_Sequence := No_Fields) |
| is |
| begin |
| Create_Type (T, Parent, Fields, Nmake_Assert => ""); |
| end Create_Abstract_Node_Type; |
| |
| ------------------------------- |
| -- Create_Concrete_Node_Type -- |
| ------------------------------- |
| |
| procedure Create_Concrete_Node_Type |
| (T : Concrete_Node; Parent : Abstract_Type; |
| Fields : Field_Sequence := No_Fields; |
| Nmake_Assert : String := "") |
| is |
| begin |
| Create_Type (T, Parent, Fields, Nmake_Assert); |
| end Create_Concrete_Node_Type; |
| |
| ----------------------------- |
| -- Create_Root_Entity_Type -- |
| ----------------------------- |
| |
| procedure Create_Root_Entity_Type |
| (T : Abstract_Entity; |
| Fields : Field_Sequence := No_Fields) is |
| begin |
| Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => ""); |
| end Create_Root_Entity_Type; |
| |
| --------------------------------- |
| -- Create_Abstract_Entity_Type -- |
| --------------------------------- |
| |
| procedure Create_Abstract_Entity_Type |
| (T : Abstract_Entity; Parent : Abstract_Type; |
| Fields : Field_Sequence := No_Fields) |
| is |
| begin |
| Create_Type (T, Parent, Fields, Nmake_Assert => ""); |
| end Create_Abstract_Entity_Type; |
| |
| --------------------------------- |
| -- Create_Concrete_Entity_Type -- |
| --------------------------------- |
| |
| procedure Create_Concrete_Entity_Type |
| (T : Concrete_Entity; Parent : Abstract_Type; |
| Fields : Field_Sequence := No_Fields) |
| is |
| begin |
| Create_Type (T, Parent, Fields, Nmake_Assert => ""); |
| end Create_Concrete_Entity_Type; |
| |
| ------------------ |
| -- Create_Field -- |
| ------------------ |
| |
| function Create_Field |
| (Field : Field_Enum; |
| Field_Type : Type_Enum; |
| Default_Value : Field_Default_Value; |
| Type_Only : Type_Only_Enum; |
| Pre, Pre_Get, Pre_Set : String; |
| Is_Syntactic : Boolean) return Field_Desc |
| is |
| begin |
| -- Note that this function has the side effect of update the |
| -- Field_Table. |
| |
| pragma Assert (if Default_Value /= No_Default then Is_Syntactic); |
| pragma Assert (if Type_Only /= No_Type_Only then not Is_Syntactic); |
| |
| -- First time this field has been seen; create an entry in the |
| -- Field_Table. |
| |
| if Field_Table (Field) = null then |
| Field_Table (Field) := new Field_Info' |
| (Type_Vectors.Empty_Vector, Field_Type, Default_Value, Type_Only, |
| Pre => new String'(Pre), |
| Pre_Get => new String'(Pre_Get), |
| Pre_Set => new String'(Pre_Set), |
| Offset => <>); -- filled in later |
| |
| -- The Field_Table entry has already been created by the 'then' part |
| -- above. Now we're seeing the same field being "created" again in a |
| -- different type. Here we check consistency of this new Create_Field |
| -- call with the old one. |
| |
| else |
| if Field_Type /= Field_Table (Field).Field_Type then |
| raise Illegal with |
| "mismatched field types for " & Image (Field); |
| end if; |
| |
| -- Check that default values for syntactic fields match. This check |
| -- could be stricter; it currently allows a field to have No_Default |
| -- in one type, but something else in another type. In that case, we |
| -- use the "something else" for all types. |
| -- |
| -- Note that the order of calls does not matter; a default value |
| -- always overrides a No_Default value. |
| |
| if Is_Syntactic then |
| if Default_Value /= Field_Table (Field).Default_Value then |
| if Field_Table (Field).Default_Value = No_Default then |
| Field_Table (Field).Default_Value := Default_Value; |
| else |
| raise Illegal with |
| "mismatched default values for " & Image (Field); |
| end if; |
| end if; |
| end if; |
| |
| if Type_Only /= Field_Table (Field).Type_Only then |
| raise Illegal with "mismatched Type_Only for " & Image (Field); |
| end if; |
| |
| if Pre /= Field_Table (Field).Pre.all then |
| raise Illegal with |
| "mismatched extra preconditions for " & Image (Field); |
| end if; |
| |
| if Pre_Get /= Field_Table (Field).Pre_Get.all then |
| raise Illegal with |
| "mismatched extra getter-only preconditions for " & |
| Image (Field); |
| end if; |
| |
| if Pre_Set /= Field_Table (Field).Pre_Set.all then |
| raise Illegal with |
| "mismatched extra setter-only preconditions for " & |
| Image (Field); |
| end if; |
| end if; |
| |
| return (Field, Is_Syntactic); |
| end Create_Field; |
| |
| ---------------------------- |
| -- Create_Syntactic_Field -- |
| ---------------------------- |
| |
| function Create_Syntactic_Field |
| (Field : Node_Field; |
| Field_Type : Type_Enum; |
| Default_Value : Field_Default_Value := No_Default; |
| Pre, Pre_Get, Pre_Set : String := "") return Field_Desc |
| is |
| begin |
| return Create_Field |
| (Field, Field_Type, Default_Value, No_Type_Only, |
| Pre, Pre_Get, Pre_Set, |
| Is_Syntactic => True); |
| end Create_Syntactic_Field; |
| |
| --------------------------- |
| -- Create_Semantic_Field -- |
| --------------------------- |
| |
| function Create_Semantic_Field |
| (Field : Field_Enum; |
| Field_Type : Type_Enum; |
| Type_Only : Type_Only_Enum := No_Type_Only; |
| Pre, Pre_Get, Pre_Set : String := "") return Field_Desc |
| is |
| begin |
| return Create_Field |
| (Field, Field_Type, No_Default, Type_Only, |
| Pre, Pre_Get, Pre_Set, |
| Is_Syntactic => False); |
| end Create_Semantic_Field; |
| |
| ----------------------- |
| -- Create_Union_Type -- |
| ----------------------- |
| |
| procedure Create_Union_Type |
| (Root : Root_Type; T : Abstract_Type; Children : Type_Array) |
| is |
| Children_Seen : Type_Set := (others => False); |
| |
| begin |
| Check_Type (T); |
| |
| if Children'Length <= 1 then |
| raise Illegal with Image (T) & " must have two or more children"; |
| end if; |
| |
| for Child of Children loop |
| if Children_Seen (Child) then |
| raise Illegal with |
| Image (T) & " has duplicate child " & Image (Child); |
| end if; |
| |
| Children_Seen (Child) := True; |
| |
| if Type_Table (Child) = null then |
| raise Illegal with |
| "undefined child type for " & |
| Image (T) & " (child is " & Image (Child) & ")"; |
| end if; |
| end loop; |
| |
| Type_Table (T) := |
| new Type_Info' |
| (Is_Union => True, Parent => Root, |
| Children | Concrete_Descendants => Type_Vectors.Empty_Vector); |
| |
| for Child of Children loop |
| Append (Type_Table (T).Children, Child); |
| end loop; |
| end Create_Union_Type; |
| |
| ---------------------------- |
| -- Create_Node_Union_Type -- |
| ---------------------------- |
| |
| procedure Create_Node_Union_Type |
| (T : Abstract_Node; Children : Type_Array) is |
| begin |
| Create_Union_Type (Node_Kind, T, Children); |
| end Create_Node_Union_Type; |
| |
| ------------------------------ |
| -- Create_Entity_Union_Type -- |
| ------------------------------ |
| |
| procedure Create_Entity_Union_Type |
| (T : Abstract_Entity; Children : Type_Array) is |
| begin |
| Create_Union_Type (Entity_Kind, T, Children); |
| end Create_Entity_Union_Type; |
| |
| ------------- |
| -- Compile -- |
| ------------- |
| |
| procedure Compile is |
| Fields_Per_Node : Fields_Per_Node_Type := (others => (others => False)); |
| |
| Type_Bit_Size : array (Concrete_Type) of Bit_Offset := (others => 0); |
| Min_Node_Bit_Size : Bit_Offset := Bit_Offset'Last; |
| Max_Node_Bit_Size : Bit_Offset := 0; |
| Min_Entity_Bit_Size : Bit_Offset := Bit_Offset'Last; |
| Max_Entity_Bit_Size : Bit_Offset := 0; |
| -- Above are in units of bits; following are in units of slots: |
| Min_Node_Size : Field_Offset := Field_Offset'Last; |
| Max_Node_Size : Field_Offset := 0; |
| Min_Entity_Size : Field_Offset := Field_Offset'Last; |
| Max_Entity_Size : Field_Offset := 0; |
| |
| Average_Node_Size_In_Slots : Long_Float; |
| |
| Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set; |
| |
| Setter_Needs_Parent : Field_Set := |
| (Actions | Expression | Then_Actions | Else_Actions => True, |
| others => False); |
| -- Set of fields where the setter should set the Parent. True for |
| -- syntactic fields of type Node_Id and List_Id, but with some |
| -- exceptions. Expression is syntactic AND semantic, and the Parent |
| -- is needed. Default_Expression is also both, but the Parent is not |
| -- needed. Then_Actions and Else_Actions are not syntactic, but the |
| -- Parent is needed. |
| |
| procedure Check_Completeness; |
| -- Check that every type and field has been declared |
| |
| procedure Compute_Ranges (Root : Root_Type); |
| -- Compute the range of Node_Kind/Entity_Kind values for all the types |
| -- rooted at Root. The result is stored in the First and Last components |
| -- in the Type_Table. |
| |
| procedure Compute_Fields_Per_Node; |
| -- Compute which fields are in which nodes. Implements inheritance of |
| -- fields. Set the Fields component of each Type_Info to include |
| -- inherited ones. Set the Is_Syntactic component in the Type_Table to |
| -- the set of fields that are syntactic in that node kind. Set the |
| -- Fields_Per_Node table. |
| |
| procedure Compute_Field_Offsets; |
| -- Compute the offsets of each field. The results are stored in the |
| -- Offset components in the Field_Table. |
| |
| procedure Compute_Type_Sizes; |
| -- Compute the size of each node and entity type, which is one more than |
| -- the maximum bit offset of all fields of the type. Results are |
| -- returned in the above Type_Bit_Size and Min_.../Max_... variables. |
| |
| procedure Check_For_Syntactic_Field_Mismatch; |
| -- Check that fields are either all syntactic or all semantic in all |
| -- nodes in which they exist, except for some fields that already |
| -- violate this rule. |
| -- |
| -- Also sets Setter_Needs_Parent. |
| |
| function Field_Types_Used (First, Last : Field_Enum) return Type_Set; |
| -- Returns the union of the types of all the fields in the range First |
| -- .. Last. Only Special_Type; if the declared type of a field is a |
| -- descendant of Node_Kind or Entity_Kind, then the low-level getter for |
| -- Node_Id can be used. |
| |
| procedure Put_Seinfo; |
| -- Print out the Seinfo package, which is with'ed by both Sinfo.Nodes |
| -- and Einfo.Entities. |
| |
| procedure Put_Nodes; |
| -- Print out the Sinfo.Nodes package spec and body |
| |
| procedure Put_Entities; |
| -- Print out the Einfo.Entities package spec and body |
| |
| procedure Put_Type_And_Subtypes |
| (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nodes and Put_Entities to print out the main type |
| -- and subtype declarations in Sinfo.Nodes and Einfo.Entities. |
| |
| procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nodes and Put_Entities to print out the subprogram |
| -- declarations in Sinfo.Nodes and Einfo.Entities. |
| |
| procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nodes and Put_Entities to print out the subprogram |
| -- bodies in Sinfo.Nodes and Einfo.Entities. |
| |
| function Node_To_Fetch_From (F : Field_Enum) return String; |
| -- Name of the Node from which a getter should fetch the value. |
| -- Normally, we fetch from the node or entity passed in (i.e. formal |
| -- parameter N). But if Type_Only was specified, we need to fetch the |
| -- corresponding base (etc) type. |
| |
| procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum); |
| 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_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 |
| -- setter for the given field. |
| |
| procedure Put_Precondition |
| (S : in out Sink; F : Field_Enum); |
| -- Print out the precondition, if any, for a getter or setter for the |
| -- given field. |
| |
| procedure Put_Low_Level_Accessor_Instantiations |
| (S : in out Sink; T : Type_Enum); |
| -- Print out the low-level getter and setter for a given type |
| |
| procedure Put_Traversed_Fields (S : in out Sink); |
| -- Called by Put_Nodes to print out the Traversed_Fields table in |
| -- Sinfo.Nodes. |
| |
| procedure Put_Tables (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nodes and Put_Entities to print out the various tables |
| -- in Sinfo.Nodes and Einfo.Entities. |
| |
| procedure Put_Nmake; |
| -- Print out the Nmake package spec and body, containing |
| -- Make_... functions for each concrete node type. |
| |
| procedure Put_Make_Decls (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nmake to print out the Make_... function declarations |
| |
| procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type); |
| -- Called by Put_Nmake to print out the Make_... function bodies |
| |
| procedure Put_Make_Spec |
| (S : in out Sink; Root : Root_Type; T : Concrete_Type); |
| -- Called by Put_Make_Decls and Put_Make_Bodies to print out the spec of |
| -- a single Make_... function. |
| |
| procedure Put_Seinfo_Tables; |
| -- This puts information about both sinfo and einfo. |
| -- Not actually needed by the compiler. |
| |
| procedure Put_Sinfo_Dot_H; |
| -- Print out the sinfo.h file |
| |
| procedure Put_Einfo_Dot_H; |
| -- Print out the einfo.h file |
| |
| procedure Put_C_Type_And_Subtypes |
| (S : in out Sink; Root : Root_Type); |
| -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out the C code |
| -- 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 |
| (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 |
| (S : in out Sink; F : Field_Enum); |
| -- Used by Put_High_Level_C_Getters to print out one high-level getter. |
| |
| procedure Put_Union_Membership |
| (S : in out Sink; Root : Root_Type); |
| -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to |
| -- test membership in a union type. |
| |
| ------------------------ |
| -- Check_Completeness -- |
| ------------------------ |
| |
| procedure Check_Completeness is |
| begin |
| for T in Node_Or_Entity_Type loop |
| if Type_Table (T) = null and then T not in Type_Boundaries then |
| raise Illegal with "Missing type declaration for " & Image (T); |
| end if; |
| end loop; |
| |
| for F in Field_Enum loop |
| if Field_Table (F) = null |
| and then F /= Between_Node_And_Entity_Fields |
| then |
| raise Illegal with "Missing field declaration for " & Image (F); |
| end if; |
| end loop; |
| end Check_Completeness; |
| |
| -------------------- |
| -- Compute_Ranges -- |
| -------------------- |
| |
| procedure Compute_Ranges (Root : Root_Type) is |
| |
| procedure Do_One_Type (T : Node_Or_Entity_Type); |
| -- Compute the range for one type. Passed to Iterate_Types to process |
| -- all of them. |
| |
| procedure Add_Concrete_Descendant_To_Ancestors |
| (Ancestor : Abstract_Type; Descendant : Concrete_Type); |
| -- Add Descendant to the Concrete_Descendants of each of its |
| -- ancestors. |
| |
| procedure Add_Concrete_Descendant_To_Ancestors |
| (Ancestor : Abstract_Type; Descendant : Concrete_Type) is |
| begin |
| if Ancestor not in Root_Type then |
| Add_Concrete_Descendant_To_Ancestors |
| (Type_Table (Ancestor).Parent, Descendant); |
| end if; |
| |
| Append (Type_Table (Ancestor).Concrete_Descendants, Descendant); |
| end Add_Concrete_Descendant_To_Ancestors; |
| |
| procedure Do_One_Type (T : Node_Or_Entity_Type) is |
| begin |
| case T is |
| when Concrete_Type => |
| pragma Annotate (Codepeer, Modified, Type_Table); |
| Type_Table (T).First := T; |
| Type_Table (T).Last := T; |
| Add_Concrete_Descendant_To_Ancestors |
| (Type_Table (T).Parent, T); |
| |
| when Abstract_Type => |
| declare |
| Children : Type_Vector renames Type_Table (T).Children; |
| begin |
| -- Ensure that an abstract type is not a leaf in the type |
| -- hierarchy. |
| |
| if Is_Empty (Children) then |
| raise Illegal with Image (T) & " has no children"; |
| end if; |
| |
| -- We could support abstract types with only one child, |
| -- but what's the point of having such a type? |
| |
| if Last_Index (Children) = 1 then |
| raise Illegal with Image (T) & " has only one child"; |
| end if; |
| |
| Type_Table (T).First := Type_Table (Children (1)).First; |
| Type_Table (T).Last := |
| Type_Table (Children (Last_Index (Children))).Last; |
| end; |
| |
| when Between_Abstract_Entity_And_Concrete_Node_Types => |
| raise Program_Error; |
| end case; |
| end Do_One_Type; |
| begin |
| Iterate_Types (Root, Post => Do_One_Type'Access); |
| end Compute_Ranges; |
| |
| ----------------------------- |
| -- Compute_Fields_Per_Node -- |
| ----------------------------- |
| |
| procedure Compute_Fields_Per_Node is |
| |
| Duplicate_Fields_Found : Boolean := False; |
| |
| function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector; |
| -- Compute the fields of a given type. This is the fields inherited |
| -- from ancestors, plus the fields declared for the type itself. |
| |
| function Get_Syntactic_Fields |
| (T : Node_Or_Entity_Type) return Field_Set; |
| -- Compute the set of fields that are syntactic for a given type. |
| -- Note that a field can be syntactic in some node types, but |
| -- semantic in others. |
| |
| procedure Do_Concrete_Type (CT : Concrete_Type); |
| -- Do the Compute_Fields_Per_Node work for a concrete type |
| |
| function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector is |
| Parent_Fields : constant Field_Vector := |
| (if T in Root_Type then Field_Vectors.Empty_Vector |
| else Get_Fields (Type_Table (T).Parent)); |
| begin |
| return Parent_Fields & Type_Table (T).Fields; |
| end Get_Fields; |
| |
| function Get_Syntactic_Fields |
| (T : Node_Or_Entity_Type) return Field_Set |
| is |
| Parent_Is_Syntactic : constant Field_Set := |
| (if T in Root_Type then (Field_Enum => False) |
| else Get_Syntactic_Fields (Type_Table (T).Parent)); |
| begin |
| return Parent_Is_Syntactic or Syntactic (T); |
| end Get_Syntactic_Fields; |
| |
| procedure Do_Concrete_Type (CT : Concrete_Type) is |
| begin |
| Type_Table (CT).Fields := Get_Fields (CT); |
| Syntactic (CT) := Get_Syntactic_Fields (CT); |
| |
| for F of Type_Table (CT).Fields loop |
| if Fields_Per_Node (CT) (F) then |
| Ada.Text_IO.Put_Line |
| ("duplicate field" & Image (CT) & Image (F)); |
| Duplicate_Fields_Found := True; |
| end if; |
| |
| Fields_Per_Node (CT) (F) := True; |
| end loop; |
| end Do_Concrete_Type; |
| |
| begin -- Compute_Fields_Per_Node |
| for CT in Concrete_Node loop |
| Do_Concrete_Type (CT); |
| end loop; |
| |
| -- The node fields defined for all three N_Entity kinds should be the |
| -- same: |
| |
| if Type_Table (N_Defining_Character_Literal).Fields /= |
| Type_Table (N_Defining_Identifier).Fields |
| then |
| raise Illegal with |
| "fields for N_Defining_Identifier and " & |
| "N_Defining_Character_Literal must match"; |
| end if; |
| |
| if Type_Table (N_Defining_Operator_Symbol).Fields /= |
| Type_Table (N_Defining_Identifier).Fields |
| then |
| raise Illegal with |
| "fields for N_Defining_Identifier and " & |
| "N_Defining_Operator_Symbol must match"; |
| end if; |
| |
| if Fields_Per_Node (N_Defining_Character_Literal) /= |
| Fields_Per_Node (N_Defining_Identifier) |
| then |
| raise Illegal with |
| "Fields of N_Defining_Character_Literal must match " & |
| "N_Defining_Identifier"; |
| end if; |
| |
| if Fields_Per_Node (N_Defining_Operator_Symbol) /= |
| Fields_Per_Node (N_Defining_Identifier) |
| then |
| raise Illegal with |
| "Fields of N_Defining_Operator_Symbol must match " & |
| "N_Defining_Identifier"; |
| end if; |
| |
| -- Copy node fields from N_Entity nodes to entities, so they have |
| -- slots allocated (but the getters and setters are only in |
| -- Sinfo.Nodes). |
| |
| Type_Table (Entity_Kind).Fields := |
| Type_Table (N_Defining_Identifier).Fields & |
| Type_Table (Entity_Kind).Fields; |
| |
| for CT in Concrete_Entity loop |
| Do_Concrete_Type (CT); |
| end loop; |
| |
| if Duplicate_Fields_Found then |
| raise Illegal with "duplicate fields found"; |
| end if; |
| end Compute_Fields_Per_Node; |
| |
| function Field_Size (T : Type_Enum) return Bit_Offset is |
| (case T is |
| when Flag => 1, |
| |
| when Small_Paren_Count_Type | Component_Alignment_Kind => 2, |
| |
| when Node_Kind_Type | Entity_Kind_Type | Convention_Id => 8, |
| |
| when Mechanism_Type |
| | List_Id |
| | Elist_Id |
| | Name_Id |
| | String_Id |
| | Uint |
| | Uint_Subtype |
| | Ureal |
| | Source_Ptr |
| | Union_Id |
| | Node_Id |
| | Node_Or_Entity_Type => 32, |
| |
| when Between_Special_And_Abstract_Node_Types => -- can't happen |
| Bit_Offset'Last); |
| -- Size in bits of a a field of type T. It must be a power of 2, and |
| -- must match the size of the type in GNAT, which sometimes requires |
| -- a Size clause in GNAT. |
| -- |
| -- Note that this is not the same as Type_Bit_Size of the field's |
| -- type. For one thing, Type_Bit_Size only covers concrete node and |
| -- entity types, which does not include most of the above. For |
| -- another thing, Type_Bit_Size includes the full size of all the |
| -- fields, whereas a field of a node or entity type is just a 32-bit |
| -- Node_Id or Entity_Id; i.e. it is indirect. |
| |
| function Field_Size (F : Field_Enum) return Bit_Offset is |
| (Field_Size (Field_Table (F).Field_Type)); |
| |
| function To_Bit_Offset (F : Field_Enum; Offset : Field_Offset'Base) |
| return Bit_Offset'Base is |
| (Bit_Offset'Base (Offset) * Field_Size (F)); |
| function First_Bit (F : Field_Enum; Offset : Field_Offset) |
| return Bit_Offset is |
| (To_Bit_Offset (F, Offset)); |
| function Last_Bit (F : Field_Enum; Offset : Field_Offset) |
| return Bit_Offset is |
| (To_Bit_Offset (F, Offset + 1) - 1); |
| |
| function To_Size_In_Slots (Size_In_Bits : Bit_Offset) |
| return Field_Offset is |
| ((Field_Offset (Size_In_Bits) + 31) / 32); |
| |
| 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 |
| |
| --------------------------- |
| -- Compute_Field_Offsets -- |
| --------------------------- |
| |
| procedure Compute_Field_Offsets is |
| type Offset_Set_Unconstrained is array (Bit_Offset range <>) |
| of Boolean with Pack; |
| subtype Offset_Set is Offset_Set_Unconstrained (Bit_Offset); |
| Offset_Sets : array (Concrete_Type) of Offset_Set := |
| (others => (others => False)); |
| |
| function All_False |
| (F : Field_Enum; Offset : Field_Offset) |
| return Offset_Set_Unconstrained is |
| (First_Bit (F, Offset) .. Last_Bit (F, Offset) => False); |
| |
| function All_True |
| (F : Field_Enum; Offset : Field_Offset) |
| return Offset_Set_Unconstrained is |
| (First_Bit (F, Offset) .. Last_Bit (F, Offset) => True); |
| |
| function Offset_OK |
| (F : Field_Enum; Offset : Field_Offset) return Boolean; |
| -- True if it is OK to choose this offset; that is, if this offset is |
| -- not in use for any type that has the field. If Overlay_Fields is |
| -- False, then "any type that has the field" --> "any type, whether |
| -- or not it has the field". |
| |
| procedure Set_Offset_In_Use |
| (F : Field_Enum; Offset : Field_Offset); |
| -- Mark the offset as "in use" |
| |
| function Choose_Offset |
| (F : Field_Enum) return Field_Offset; |
| -- Choose an offset for this field |
| |
| function Offset_OK |
| (F : Field_Enum; Offset : Field_Offset) return Boolean is |
| begin |
| for T in Concrete_Type loop |
| if Fields_Per_Node (T) (F) or else not Overlay_Fields then |
| declare |
| Bits : Offset_Set_Unconstrained renames |
| Offset_Sets (T) |
| (First_Bit (F, Offset) .. Last_Bit (F, Offset)); |
| begin |
| if Bits /= All_False (F, Offset) then |
| return False; |
| end if; |
| end; |
| end if; |
| end loop; |
| |
| return True; |
| end Offset_OK; |
| |
| procedure Set_Offset_In_Use |
| (F : Field_Enum; Offset : Field_Offset) is |
| begin |
| for T in Concrete_Type loop |
| if Fields_Per_Node (T) (F) then |
| declare |
| Bits : Offset_Set_Unconstrained renames |
| Offset_Sets (T) |
| (First_Bit (F, Offset) .. Last_Bit (F, Offset)); |
| begin |
| pragma Assert (Bits = All_False (F, Offset)); |
| Bits := All_True (F, Offset); |
| end; |
| end if; |
| end loop; |
| end Set_Offset_In_Use; |
| |
| function Choose_Offset |
| (F : Field_Enum) return Field_Offset is |
| begin |
| for Offset in Field_Offset loop |
| if Offset_OK (F, Offset) then |
| Set_Offset_In_Use (F, Offset); |
| |
| return Offset; |
| end if; |
| end loop; |
| |
| raise Illegal with "No available field offset for " & Image (F) & |
| "; need to increase Gen_IL.Internals.Bit_Offset'Last (" & |
| Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)"; |
| end Choose_Offset; |
| |
| Num_Concrete_Have_Field : array (Field_Enum) of Type_Count := |
| (others => 0); |
| -- Number of concrete types that have each field |
| |
| function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is |
| (Num_Concrete_Have_Field (F1) > Num_Concrete_Have_Field (F2)); |
| -- True if F1 appears in more concrete types than F2 |
| |
| function Sort_Less (F1, F2 : Field_Enum) return Boolean is |
| (if Num_Concrete_Have_Field (F1) = Num_Concrete_Have_Field (F2) then |
| F1 < F2 |
| else More_Types_Have_Field (F1, F2)); |
| |
| package Sorting is new Field_Vectors.Generic_Sorting |
| ("<" => Sort_Less); |
| |
| All_Fields : Field_Vector; |
| |
| begin |
| |
| -- Compute the number of types that have each field |
| |
| for T in Concrete_Type loop |
| for F in Field_Enum loop |
| if Fields_Per_Node (T) (F) then |
| Num_Concrete_Have_Field (F) := |
| Num_Concrete_Have_Field (F) + 1; |
| end if; |
| end loop; |
| end loop; |
| |
| -- Collect all the fields in All_Fields |
| |
| for F in Node_Field loop |
| Append (All_Fields, F); |
| end loop; |
| |
| for F in Entity_Field loop |
| Append (All_Fields, F); |
| end loop; |
| |
| -- Sort All_Fields based on how many concrete types have the field. |
| -- This is for efficiency; we want to choose the offsets of the most |
| -- common fields first, so they get low numbers. |
| |
| Sorting.Sort (All_Fields); |
| |
| -- Go through all the fields, and choose the lowest offset that is |
| -- free in all types that have the field. This is basically a |
| -- graph-coloring algorithm on the interference graph. The |
| -- interference graph is an undirected graph with the fields being |
| -- nodes (not nodes in the compiler!) in the graph, and an edge |
| -- between a pair of fields if they appear in the same node in the |
| -- compiler. The "colors" are fields offsets, except that a |
| -- complication compared to standard graph coloring is that fields |
| -- are different sizes. |
| |
| for F of All_Fields loop |
| Field_Table (F).Offset := Choose_Offset (F); |
| end loop; |
| |
| end Compute_Field_Offsets; |
| |
| ------------------------ |
| -- Compute_Type_Sizes -- |
| ------------------------ |
| |
| procedure Compute_Type_Sizes is |
| -- Node_Counts is the number of nodes of each kind created during |
| -- compilation of a large example. This is used purely to compute an |
| -- estimate of the average node size. New node types can default to |
| -- "others => 0". At some point we can instrument Atree to print out |
| -- accurate size statistics, and remove this code. |
| |
| Node_Counts : constant array (Concrete_Node) of Natural := |
| (N_Identifier => 429298, |
| N_Defining_Identifier => 231636, |
| N_Integer_Literal => 90892, |
| N_Parameter_Specification => 62811, |
| N_Attribute_Reference => 47150, |
| N_Expanded_Name => 37375, |
| N_Selected_Component => 30699, |
| N_Subprogram_Declaration => 20744, |
| N_Freeze_Entity => 20314, |
| N_Procedure_Specification => 18901, |
| N_Object_Declaration => 18023, |
| N_Function_Specification => 16570, |
| N_Range => 16216, |
| N_Explicit_Dereference => 12198, |
| N_Component_Association => 11188, |
| N_Unchecked_Type_Conversion => 11165, |
| N_Subtype_Indication => 10727, |
| N_Procedure_Call_Statement => 10056, |
| N_Subtype_Declaration => 8141, |
| N_Handled_Sequence_Of_Statements => 8078, |
| N_Null => 7288, |
| N_Aggregate => 7222, |
| N_String_Literal => 7152, |
| N_Function_Call => 6958, |
| N_Simple_Return_Statement => 6911, |
| N_And_Then => 6867, |
| N_Op_Eq => 6845, |
| N_Call_Marker => 6683, |
| N_Pragma_Argument_Association => 6525, |
| N_Component_Definition => 6487, |
| N_Assignment_Statement => 6483, |
| N_With_Clause => 6480, |
| N_Null_Statement => 5917, |
| N_Index_Or_Discriminant_Constraint => 5877, |
| N_Generic_Association => 5667, |
| N_Full_Type_Declaration => 5573, |
| N_If_Statement => 5553, |
| N_Subprogram_Body => 5455, |
| N_Op_Add => 5443, |
| N_Type_Conversion => 5260, |
| N_Component_Declaration => 5059, |
| N_Raise_Constraint_Error => 4840, |
| N_Formal_Concrete_Subprogram_Declaration => 4602, |
| N_Expression_With_Actions => 4598, |
| N_Op_Ne => 3854, |
| N_Indexed_Component => 3834, |
| N_Op_Subtract => 3777, |
| N_Package_Specification => 3490, |
| N_Subprogram_Renaming_Declaration => 3445, |
| N_Pragma => 3427, |
| N_Case_Statement_Alternative => 3272, |
| N_Block_Statement => 3239, |
| N_Parameter_Association => 3213, |
| N_Op_Lt => 3020, |
| N_Op_Not => 2926, |
| N_Character_Literal => 2914, |
| N_Others_Choice => 2769, |
| N_Or_Else => 2576, |
| N_Itype_Reference => 2511, |
| N_Defining_Operator_Symbol => 2487, |
| N_Component_List => 2470, |
| N_Formal_Object_Declaration => 2262, |
| N_Generic_Subprogram_Declaration => 2227, |
| N_Real_Literal => 2156, |
| N_Op_Gt => 2156, |
| N_Access_To_Object_Definition => 1984, |
| N_Op_Le => 1975, |
| N_Op_Ge => 1942, |
| N_Package_Renaming_Declaration => 1811, |
| N_Formal_Type_Declaration => 1756, |
| N_Qualified_Expression => 1746, |
| N_Package_Declaration => 1729, |
| N_Record_Definition => 1651, |
| N_Allocator => 1521, |
| N_Op_Concat => 1377, |
| N_Access_Definition => 1358, |
| N_Case_Statement => 1322, |
| N_Number_Declaration => 1316, |
| N_Generic_Package_Declaration => 1311, |
| N_Slice => 1078, |
| N_Constrained_Array_Definition => 1068, |
| N_Exception_Renaming_Declaration => 1011, |
| N_Implicit_Label_Declaration => 978, |
| N_Exception_Handler => 966, |
| N_Private_Type_Declaration => 898, |
| N_Operator_Symbol => 872, |
| N_Formal_Private_Type_Definition => 867, |
| N_Range_Constraint => 849, |
| N_Aspect_Specification => 837, |
| N_Variant => 834, |
| N_Discriminant_Specification => 746, |
| N_Loop_Statement => 744, |
| N_Derived_Type_Definition => 731, |
| N_Freeze_Generic_Entity => 702, |
| N_Iteration_Scheme => 686, |
| N_Package_Instantiation => 658, |
| N_Loop_Parameter_Specification => 632, |
| N_Attribute_Definition_Clause => 608, |
| N_Compilation_Unit_Aux => 599, |
| N_Compilation_Unit => 599, |
| N_Label => 572, |
| N_Goto_Statement => 572, |
| N_In => 564, |
| N_Enumeration_Type_Definition => 523, |
| N_Object_Renaming_Declaration => 482, |
| N_If_Expression => 476, |
| N_Exception_Declaration => 472, |
| N_Reference => 455, |
| N_Incomplete_Type_Declaration => 438, |
| N_Use_Package_Clause => 401, |
| N_Unconstrained_Array_Definition => 360, |
| N_Variant_Part => 340, |
| N_Defining_Program_Unit_Name => 336, |
| N_Op_And => 334, |
| N_Raise_Program_Error => 329, |
| N_Formal_Discrete_Type_Definition => 319, |
| N_Contract => 311, |
| N_Not_In => 305, |
| N_Designator => 285, |
| N_Component_Clause => 247, |
| N_Formal_Signed_Integer_Type_Definition => 244, |
| N_Raise_Statement => 214, |
| N_Op_Expon => 205, |
| N_Op_Minus => 202, |
| N_Op_Multiply => 158, |
| N_Exit_Statement => 130, |
| N_Function_Instantiation => 129, |
| N_Discriminant_Association => 123, |
| N_Private_Extension_Declaration => 119, |
| N_Extended_Return_Statement => 117, |
| N_Op_Divide => 107, |
| N_Op_Or => 103, |
| N_Signed_Integer_Type_Definition => 101, |
| N_Record_Representation_Clause => 76, |
| N_Unchecked_Expression => 70, |
| N_Op_Abs => 63, |
| N_Elsif_Part => 62, |
| N_Formal_Floating_Point_Definition => 59, |
| N_Formal_Package_Declaration => 58, |
| N_Modular_Type_Definition => 55, |
| N_Abstract_Subprogram_Declaration => 52, |
| N_Validate_Unchecked_Conversion => 49, |
| N_Defining_Character_Literal => 36, |
| N_Raise_Storage_Error => 33, |
| N_Compound_Statement => 29, |
| N_Procedure_Instantiation => 28, |
| N_Access_Procedure_Definition => 25, |
| N_Floating_Point_Definition => 20, |
| N_Use_Type_Clause => 19, |
| N_Op_Plus => 14, |
| N_Package_Body => 13, |
| N_Op_Rem => 13, |
| N_Enumeration_Representation_Clause => 13, |
| N_Access_Function_Definition => 11, |
| N_Extension_Aggregate => 11, |
| N_Formal_Ordinary_Fixed_Point_Definition => 10, |
| N_Op_Mod => 10, |
| N_Expression_Function => 9, |
| N_Delay_Relative_Statement => 9, |
| N_Quantified_Expression => 7, |
| N_Formal_Derived_Type_Definition => 7, |
| N_Free_Statement => 7, |
| N_Iterator_Specification => 5, |
| N_Op_Shift_Left => 5, |
| N_Formal_Modular_Type_Definition => 4, |
| N_Generic_Package_Renaming_Declaration => 1, |
| N_Empty => 1, |
| N_Real_Range_Specification => 1, |
| N_Ordinary_Fixed_Point_Definition => 1, |
| N_Op_Shift_Right => 1, |
| N_Error => 1, |
| N_Mod_Clause => 1, |
| others => 0); |
| |
| Total_Node_Count : constant Long_Float := 1370676.0; |
| |
| type Node_Frequency_Table is array (Concrete_Node) of Long_Float; |
| |
| function Init_Node_Frequency return Node_Frequency_Table; |
| -- Compute the value of the Node_Frequency table |
| |
| function Average_Type_Size_In_Slots return Long_Float; |
| -- Compute the average over all concrete node types of the size, |
| -- weighted by the frequency of that node type. |
| |
| function Init_Node_Frequency return Node_Frequency_Table is |
| Result : Node_Frequency_Table := (others => 0.0); |
| |
| begin |
| for T in Concrete_Node loop |
| Result (T) := Long_Float (Node_Counts (T)) / Total_Node_Count; |
| end loop; |
| |
| return Result; |
| end Init_Node_Frequency; |
| |
| Node_Frequency : constant Node_Frequency_Table := Init_Node_Frequency; |
| -- Table mapping concrete node types to the relative frequency of |
| -- that node, in our large example. The sum of these values should |
| -- add up to approximately 1.0. For example, if Node_Frequency(K) = |
| -- 0.02, then that means that approximately 2% of all nodes are K |
| -- nodes. |
| |
| function Average_Type_Size_In_Slots return Long_Float is |
| -- We don't have data on entities, so we leave those out |
| |
| Result : Long_Float := 0.0; |
| begin |
| for T in Concrete_Node loop |
| Result := Result + |
| Node_Frequency (T) * Long_Float (Type_Size_In_Slots (T)); |
| end loop; |
| |
| return Result; |
| end Average_Type_Size_In_Slots; |
| |
| -- Start of processing for Compute_Type_Sizes |
| |
| begin |
| for T in Concrete_Type loop |
| declare |
| Max_Offset : Bit_Offset := 0; |
| |
| begin |
| for F in Field_Enum loop |
| if Fields_Per_Node (T) (F) then |
| Max_Offset := |
| Bit_Offset'Max |
| (Max_Offset, |
| To_Bit_Offset (F, Field_Table (F).Offset)); |
| end if; |
| end loop; |
| |
| Type_Bit_Size (T) := Max_Offset + 1; |
| end; |
| end loop; |
| |
| for T in Concrete_Node loop |
| Min_Node_Bit_Size := |
| Bit_Offset'Min (Min_Node_Bit_Size, Type_Bit_Size (T)); |
| Max_Node_Bit_Size := |
| Bit_Offset'Max (Max_Node_Bit_Size, Type_Bit_Size (T)); |
| end loop; |
| |
| for T in Concrete_Entity loop |
| Min_Entity_Bit_Size := |
| Bit_Offset'Min (Min_Entity_Bit_Size, Type_Bit_Size (T)); |
| Max_Entity_Bit_Size := |
| Bit_Offset'Max (Max_Entity_Bit_Size, Type_Bit_Size (T)); |
| end loop; |
| |
| Min_Node_Size := To_Size_In_Slots (Min_Node_Bit_Size); |
| Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size); |
| Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size); |
| Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size); |
| |
| Average_Node_Size_In_Slots := Average_Type_Size_In_Slots; |
| end Compute_Type_Sizes; |
| |
| ---------------------------------------- |
| -- Check_For_Syntactic_Field_Mismatch -- |
| ---------------------------------------- |
| |
| procedure Check_For_Syntactic_Field_Mismatch is |
| begin |
| for F in Field_Enum loop |
| if F /= Between_Node_And_Entity_Fields then |
| declare |
| Syntactic_Seen, Semantic_Seen : Boolean := False; |
| Have_Field : Type_Vector renames |
| Field_Table (F).Have_This_Field; |
| |
| begin |
| for J in 1 .. Last_Index (Have_Field) loop |
| if Syntactic (Have_Field (J)) (F) then |
| Syntactic_Seen := True; |
| else |
| Semantic_Seen := True; |
| end if; |
| end loop; |
| |
| -- The following fields violate this rule. We might want to |
| -- simplify by getting rid of these cases, but we allow them |
| -- for now. At least, we don't want to add any new cases of |
| -- syntactic/semantic mismatch. |
| |
| if F in Chars | Actions | Expression | Default_Expression |
| then |
| pragma Assert (Syntactic_Seen and Semantic_Seen); |
| |
| else |
| if Syntactic_Seen and Semantic_Seen then |
| raise Illegal with |
| "syntactic/semantic mismatch for " & Image (F); |
| end if; |
| |
| if Field_Table (F).Field_Type in Traversed_Field_Type |
| and then Syntactic_Seen |
| then |
| Setter_Needs_Parent (F) := True; |
| end if; |
| end if; |
| end; |
| end if; |
| end loop; |
| end Check_For_Syntactic_Field_Mismatch; |
| |
| ---------------------- |
| -- Field_Types_Used -- |
| ---------------------- |
| |
| function Field_Types_Used (First, Last : Field_Enum) return Type_Set is |
| Result : Type_Set := (others => False); |
| begin |
| for F in First .. Last loop |
| if Field_Table (F).Field_Type in Node_Or_Entity_Type then |
| Result (Node_Id) := True; |
| else |
| Result (Field_Table (F).Field_Type) := True; |
| end if; |
| end loop; |
| |
| return Result; |
| end Field_Types_Used; |
| |
| pragma Style_Checks ("M120"); |
| -- Lines of the form Put (S, "..."); are more readable if we relax the |
| -- line length. We really just want the "..." to be short enough. |
| |
| --------------------------- |
| -- Put_Type_And_Subtypes -- |
| --------------------------- |
| |
| procedure Put_Type_And_Subtypes |
| (S : in out Sink; Root : Root_Type) |
| is |
| |
| procedure Put_Enum_Type; |
| -- Print out the enumeration type declaration for a root type |
| -- (Node_Kind or Entity_Kind). |
| |
| procedure Put_Kind_Subtype (T : Node_Or_Entity_Type); |
| -- Print out a subrange (of type Node_Kind or Entity_Kind) for a |
| -- given nonroot abstract type. |
| |
| procedure Put_Id_Subtype (T : Node_Or_Entity_Type); |
| -- Print out a subtype (of type Node_Id or Entity_Id) for a given |
| -- nonroot abstract type. |
| |
| procedure Put_Enum_Type is |
| procedure Put_Enum_Lit (T : Node_Or_Entity_Type); |
| -- Print out one enumeration literal in the declaration of |
| -- Node_Kind or Entity_Kind. |
| |
| First_Time : Boolean := True; |
| |
| procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is |
| begin |
| if T in Concrete_Type then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T)); |
| end if; |
| end Put_Enum_Lit; |
| |
| type Dummy is array |
| (First_Concrete (Root) .. Last_Concrete (Root)) of Boolean; |
| Num_Types : constant Root_Int := Dummy'Length; |
| |
| begin |
| Put (S, "type " & Image (Root) & " is -- " & |
| Image (Num_Types) & " " & Image (Root) & "s" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| Iterate_Types (Root, Pre => Put_Enum_Lit'Access); |
| Decrease_Indent (S, 1); |
| Put (S, LF & ") with Size => 8; -- " & Image (Root) & LF & LF); |
| Decrease_Indent (S, 2); |
| end Put_Enum_Type; |
| |
| procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is |
| begin |
| if T in Abstract_Type then |
| if Type_Table (T).Is_Union then |
| pragma Assert (Type_Table (T).Parent = Root); |
| |
| Put (S, "subtype " & Image (T) & " is" & LF); |
| Increase_Indent (S, 2); |
| Put (S, Image (Root) & " with Predicate =>" & LF); |
| Increase_Indent (S, 2); |
| Put (S, Image (T) & " in" & LF); |
| Put_Types_With_Bars (S, Type_Table (T).Children); |
| Decrease_Indent (S, 2); |
| Put (S, ";" & LF); |
| Decrease_Indent (S, 2); |
| |
| elsif Type_Table (T).Parent /= No_Type then |
| Put (S, "subtype " & Image (T) & " is " & |
| Image (Type_Table (T).Parent) & " range" & LF); |
| Increase_Indent (S, 2); |
| Put (S, Image (Type_Table (T).First) & " .. " & |
| Image (Type_Table (T).Last) & ";" & LF); |
| Decrease_Indent (S, 2); |
| |
| Increase_Indent (S, 3); |
| |
| for J in 1 .. Type_Table (T).Concrete_Descendants.Last_Index loop |
| Put (S, "-- " & |
| Image (Type_Table (T).Concrete_Descendants (J)) & LF); |
| end loop; |
| |
| Decrease_Indent (S, 3); |
| end if; |
| end if; |
| end Put_Kind_Subtype; |
| |
| procedure Put_Id_Subtype (T : Node_Or_Entity_Type) is |
| begin |
| if Type_Table (T).Parent /= No_Type then |
| Put (S, "subtype " & Id_Image (T) & " is" & LF); |
| Increase_Indent (S, 2); |
| Put (S, Id_Image (Type_Table (T).Parent)); |
| |
| if Enable_Assertions then |
| Put (S, " with Predicate =>" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "K (" & Id_Image (T) & ") in " & Image (T)); |
| Decrease_Indent (S, 2); |
| end if; |
| |
| Put (S, ";" & LF); |
| Decrease_Indent (S, 2); |
| end if; |
| end Put_Id_Subtype; |
| |
| begin -- Put_Type_And_Subtypes |
| Put_Enum_Type; |
| |
| -- Put the getter for Nkind and Ekind here, earlier than the other |
| -- getters, because it is needed in predicates of the following |
| -- subtypes. |
| |
| case Root is |
| when Node_Kind => |
| Put_Getter_Decl (S, Nkind); |
| Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;" & LF); |
| Put (S, "-- Shorthand for use in predicates and preconditions below" & LF); |
| Put (S, "-- There is no procedure Set_Nkind." & LF); |
| Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree." & LF & LF); |
| |
| when Entity_Kind => |
| Put_Getter_Decl (S, Ekind); |
| Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;" & LF); |
| Put (S, "-- Shorthand for use in predicates and preconditions below" & LF); |
| Put (S, "-- There is no procedure Set_Ekind here." & LF); |
| Put (S, "-- See Mutate_Ekind in Atree." & LF & LF); |
| |
| when others => raise Program_Error; |
| end case; |
| |
| Put (S, "-- Subtypes of " & Image (Root) & " for each abstract type:" & LF & LF); |
| |
| Put (S, "pragma Style_Checks (""M200"");" & LF); |
| Iterate_Types (Root, Pre => Put_Kind_Subtype'Access); |
| |
| Put (S, LF & "-- Subtypes of " & Id_Image (Root) & |
| " with specified " & Image (Root) & "." & LF); |
| Put (S, "-- These may be used in place of " & Id_Image (Root) & |
| " for better documentation," & LF); |
| Put (S, "-- and if assertions are enabled, for run-time checking." & LF & LF); |
| |
| Iterate_Types (Root, Pre => Put_Id_Subtype'Access); |
| |
| Put (S, LF & "-- Union types (nonhierarchical subtypes of " & |
| Id_Image (Root) & ")" & LF & LF); |
| |
| for T in First_Abstract (Root) .. Last_Abstract (Root) loop |
| if Type_Table (T) /= null and then Type_Table (T).Is_Union then |
| Put_Kind_Subtype (T); |
| Put_Id_Subtype (T); |
| end if; |
| end loop; |
| |
| Put (S, "subtype Flag is Boolean;" & LF & LF); |
| end Put_Type_And_Subtypes; |
| |
| function Low_Level_Getter_Name (T : Type_Enum) return String is |
| ("Get_" & Image (T)); |
| function Low_Level_Setter_Name (T : Type_Enum) return String is |
| ("Set_" & Image (T)); |
| function Low_Level_Setter_Name (F : Field_Enum) return String is |
| (Low_Level_Setter_Name (Field_Table (F).Field_Type) & |
| (if Setter_Needs_Parent (F) then "_With_Parent" else "")); |
| |
| ------------------------------------------- |
| -- Put_Low_Level_Accessor_Instantiations -- |
| ------------------------------------------- |
| |
| procedure Put_Low_Level_Accessor_Instantiations |
| (S : in out Sink; T : Type_Enum) |
| is |
| 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 in Node_Kind_Type | Entity_Kind_Type then |
| Put (S, "pragma Warnings (On);" & LF); |
| end if; |
| end Put_Low_Level_Accessor_Instantiations; |
| |
| ---------------------- |
| -- Put_Precondition -- |
| ---------------------- |
| |
| procedure Put_Precondition |
| (S : in out Sink; F : Field_Enum) |
| is |
| -- If the field is present in all entities, we want to assert that |
| -- N in N_Entity_Id. If the field is present in only some entities, |
| -- we don't need that, because we are fetching Ekind in that case, |
| -- which will assert N in N_Entity_Id. |
| |
| Is_Entity : constant String := |
| (if Field_Table (F).Have_This_Field = All_Entities then |
| "N in N_Entity_Id" |
| else ""); |
| begin |
| -- If this is an entity field, then we should assert that N is an |
| -- entity. We need "N in A | B | ..." unless this is embodied in a |
| -- subtype predicate. |
| -- |
| -- We can't put the extra "Pre => ..." specified on the call to |
| -- Create_..._Field as part of the precondition, because some of |
| -- them call things that are not visible here. |
| |
| if Enable_Assertions then |
| if Length (Field_Table (F).Have_This_Field) = 1 |
| or else Field_Table (F).Have_This_Field = Nodes_And_Entities |
| then |
| if Is_Entity /= "" then |
| Increase_Indent (S, 1); |
| Put (S, ", Pre =>" & LF); |
| Put (S, Is_Entity); |
| Decrease_Indent (S, 1); |
| end if; |
| |
| else |
| Put (S, ", Pre =>" & LF); |
| Increase_Indent (S, 1); |
| Put (S, "N in "); |
| Put_Type_Ids_With_Bars (S, Field_Table (F).Have_This_Field); |
| |
| pragma Assert (Is_Entity = ""); |
| |
| Decrease_Indent (S, 1); |
| end if; |
| end if; |
| end Put_Precondition; |
| |
| function Root_Type_For_Field (F : Field_Enum) return Root_Type is |
| (case F is |
| when Node_Field => Node_Kind, |
| when Entity_Field => Entity_Kind, |
| when Between_Node_And_Entity_Fields => Node_Kind); -- can't happen |
| |
| function N_Type (F : Field_Enum) return String is |
| (if Length (Field_Table (F).Have_This_Field) = 1 then |
| Id_Image (Field_Table (F).Have_This_Field (1)) |
| else Id_Image (Root_Type_For_Field (F))); |
| -- Name of the parameter type of the N parameter of the getter and |
| -- setter for field F. If there's only one Have_This_Field, use that; |
| -- the predicate will check for the right Kind. Otherwise, we use |
| -- Node_Id or Entity_Id, and the getter and setter will have |
| -- preconditions. |
| |
| ------------------------ |
| -- Node_To_Fetch_From -- |
| ------------------------ |
| |
| function Node_To_Fetch_From (F : Field_Enum) return String is |
| begin |
| return |
| (case Field_Table (F).Type_Only is |
| when No_Type_Only => "N", |
| when Base_Type_Only => "Base_Type (N)", |
| when Impl_Base_Type_Only => "Implementation_Base_Type (N)", |
| when Root_Type_Only => "Root_Type (N)"); |
| end Node_To_Fetch_From; |
| |
| --------------------- |
| -- Put_Getter_Spec -- |
| --------------------- |
| |
| procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is |
| begin |
| Put (S, "function " & Image (F)); |
| Put (S, " (N : " & N_Type (F) & ") return " & |
| Get_Set_Id_Image (Field_Table (F).Field_Type)); |
| end Put_Getter_Spec; |
| |
| --------------------- |
| -- Put_Getter_Decl -- |
| --------------------- |
| |
| procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum) is |
| begin |
| Put_Getter_Spec (S, F); |
| Put (S, " with " & Inline); |
| Increase_Indent (S, 2); |
| Put_Precondition (S, F); |
| |
| Decrease_Indent (S, 2); |
| Put (S, ";" & LF); |
| end Put_Getter_Decl; |
| |
| --------------------- |
| -- Put_Getter_Body -- |
| --------------------- |
| |
| procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is |
| Rec : Field_Info renames Field_Table (F).all; |
| 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 |
| -- that it has the same name as the formal of the setter, so the |
| -- "Pre => ..." can refer to it by the same name in both getter |
| -- 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); |
| Decrease_Indent (S, 3); |
| Put (S, "begin" & LF); |
| Increase_Indent (S, 3); |
| |
| if Rec.Pre.all /= "" then |
| Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF); |
| end if; |
| |
| if Rec.Pre_Get.all /= "" then |
| Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF); |
| end if; |
| |
| Put (S, "return Val;" & LF); |
| Decrease_Indent (S, 3); |
| Put (S, "end " & Image (F) & ";" & LF & LF); |
| end Put_Getter_Body; |
| |
| --------------------- |
| -- Put_Setter_Spec -- |
| --------------------- |
| |
| procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum) is |
| Rec : Field_Info renames Field_Table (F).all; |
| Default : constant String := |
| (if Rec.Field_Type = Flag then " := True" else ""); |
| begin |
| Put (S, "procedure Set_" & Image (F)); |
| Put (S, " (N : " & N_Type (F) & "; Val : " & |
| Get_Set_Id_Image (Rec.Field_Type) & Default & ")"); |
| end Put_Setter_Spec; |
| |
| --------------------- |
| -- Put_Setter_Decl -- |
| --------------------- |
| |
| procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum) is |
| begin |
| Put_Setter_Spec (S, F); |
| Put (S, " with " & Inline); |
| Increase_Indent (S, 2); |
| Put_Precondition (S, F); |
| Decrease_Indent (S, 2); |
| Put (S, ";" & LF); |
| end Put_Setter_Decl; |
| |
| --------------------- |
| -- Put_Setter_Body -- |
| --------------------- |
| |
| procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is |
| Rec : Field_Info renames Field_Table (F).all; |
| |
| -- 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 |
| -- it is an implementation base type or a root type. |
| |
| Type_Only_Assertion : constant String := |
| (case Rec.Type_Only is |
| when No_Type_Only => "", |
| when Base_Type_Only | Impl_Base_Type_Only | Root_Type_Only => |
| "Is_Base_Type (N)"); |
| begin |
| Put_Setter_Spec (S, F); |
| Put (S, " is" & LF); |
| Put (S, "begin" & LF); |
| Increase_Indent (S, 3); |
| |
| if Rec.Pre.all /= "" then |
| Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF); |
| end if; |
| |
| if Rec.Pre_Set.all /= "" then |
| Put (S, "pragma Assert (" & Rec.Pre_Set.all & ");" & LF); |
| end if; |
| |
| if Type_Only_Assertion /= "" then |
| Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF); |
| end if; |
| |
| Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset) |
| & ", Val);" & LF); |
| Decrease_Indent (S, 3); |
| Put (S, "end Set_" & Image (F) & ";" & LF & LF); |
| end Put_Setter_Body; |
| |
| -------------------- |
| -- Put_Subp_Decls -- |
| -------------------- |
| |
| procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type) is |
| -- Note that there are several fields that are defined for both nodes |
| -- and entities, such as Nkind. These are allocated slots in both, |
| -- but here we only put out getters and setters in Sinfo.Nodes, not |
| -- Einfo.Entities. |
| |
| begin |
| Put (S, "-- Getters and setters for fields" & LF); |
| |
| for F in First_Field (Root) .. Last_Field (Root) loop |
| -- Nkind/Ekind getter is already done (see Put_Type_And_Subtypes), |
| -- and there is no setter for these. |
| |
| if F = Nkind then |
| Put (S, LF & "-- Nkind getter is above" & LF); |
| |
| elsif F = Ekind then |
| Put (S, LF & "-- Ekind getter is above" & LF); |
| |
| else |
| Put_Getter_Decl (S, F); |
| Put_Setter_Decl (S, F); |
| end if; |
| |
| Put (S, LF); |
| end loop; |
| end Put_Subp_Decls; |
| |
| --------------------- |
| -- Put_Subp_Bodies -- |
| --------------------- |
| |
| procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type) is |
| begin |
| Put (S, LF & "-- Getters and setters for fields" & LF & LF); |
| |
| for F in First_Field (Root) .. Last_Field (Root) loop |
| Put_Getter_Body (S, F); |
| |
| if F not in Nkind | Ekind then |
| Put_Setter_Body (S, F); |
| end if; |
| end loop; |
| end Put_Subp_Bodies; |
| |
| -------------------------- |
| -- Put_Traversed_Fields -- |
| -------------------------- |
| |
| procedure Put_Traversed_Fields (S : in out Sink) is |
| |
| function Is_Traversed_Field |
| (T : Concrete_Node; F : Field_Enum) return Boolean; |
| -- True if F is a field that should be traversed by Traverse_Func. In |
| -- particular, True if F is a syntactic field of T, and is of a |
| -- Node_Id or List_Id type. |
| |
| function Init_Max_Traversed_Fields return Field_Offset; |
| -- Compute the maximum number of syntactic fields that are of type |
| -- Node_Id or List_Id over all node types. |
| |
| procedure Put_Aggregate (T : Node_Or_Entity_Type); |
| -- Print out the subaggregate for one type |
| |
| function Is_Traversed_Field |
| (T : Concrete_Node; F : Field_Enum) return Boolean is |
| begin |
| return Syntactic (T) (F) |
| and then Field_Table (F).Field_Type in Traversed_Field_Type; |
| end Is_Traversed_Field; |
| |
| First_Time : Boolean := True; |
| |
| procedure Put_Aggregate (T : Node_Or_Entity_Type) is |
| Left_Opnd_Skipped : Boolean := False; |
| begin |
| if T in Concrete_Node then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T) & " => ("); |
| Increase_Indent (S, 2); |
| |
| for FI in 1 .. Last_Index (Type_Table (T).Fields) loop |
| declare |
| F : constant Field_Enum := Type_Table (T).Fields (FI); |
| |
| begin |
| if Is_Traversed_Field (T, F) then |
| if F = Left_Opnd then |
| Left_Opnd_Skipped := True; -- see comment below |
| |
| else |
| Put (S, Image (Field_Table (F).Offset) & ", "); |
| end if; |
| end if; |
| end; |
| end loop; |
| |
| -- We always put the Left_Opnd field of N_Op_Concat last. See |
| -- comments in Atree.Traverse_Func for the reason. We might as |
| -- well do that for all Left_Opnd fields; the old version did |
| -- that. |
| |
| if Left_Opnd_Skipped then |
| Put (S, Image (Field_Table (Left_Opnd).Offset) & ", "); |
| end if; |
| |
| Put (S, "others => No_Field_Offset"); |
| |
| Decrease_Indent (S, 2); |
| Put (S, ")"); |
| end if; |
| end Put_Aggregate; |
| |
| function Init_Max_Traversed_Fields return Field_Offset is |
| Result : Field_Offset := 0; |
| begin |
| for T in Concrete_Node loop |
| declare |
| Num_Traversed_Fields : Field_Offset := 0; -- in type T |
| |
| begin |
| for FI in 1 .. Last_Index (Type_Table (T).Fields) loop |
| declare |
| F : constant Field_Enum := Type_Table (T).Fields (FI); |
| |
| begin |
| if Is_Traversed_Field (T, F) then |
| Num_Traversed_Fields := Num_Traversed_Fields + 1; |
| end if; |
| end; |
| end loop; |
| |
| if Num_Traversed_Fields > Result then |
| Result := Num_Traversed_Fields; |
| end if; |
| end; |
| end loop; |
| |
| return Result; |
| end Init_Max_Traversed_Fields; |
| |
| Max_Traversed_Fields : constant Field_Offset := |
| Init_Max_Traversed_Fields; |
| |
| begin |
| Put (S, "-- Table of fields that should be traversed by Traverse subprograms." & LF); |
| Put (S, "-- Each entry is an array of offsets in slots of fields to be" & LF); |
| Put (S, "-- traversed, terminated by a sentinel equal to No_Field_Offset." & LF & LF); |
| |
| Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. " & |
| Image (Max_Traversed_Fields - 1) & " + 1);" & LF); |
| Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=" & LF); |
| -- One extra for the sentinel |
| |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| Iterate_Types (Node_Kind, Pre => Put_Aggregate'Access); |
| Decrease_Indent (S, 1); |
| Put (S, ");" & LF & LF); |
| Decrease_Indent (S, 2); |
| end Put_Traversed_Fields; |
| |
| ---------------- |
| -- Put_Tables -- |
| ---------------- |
| |
| procedure Put_Tables (S : in out Sink; Root : Root_Type) is |
| |
| First_Time : Boolean := True; |
| |
| procedure Put_Size (T : Node_Or_Entity_Type); |
| procedure Put_Size (T : Node_Or_Entity_Type) is |
| begin |
| if T in Concrete_Type then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T) & " => " & Image (Type_Size_In_Slots (T))); |
| end if; |
| end Put_Size; |
| |
| procedure Put_Field_Array (T : Concrete_Type); |
| |
| procedure Put_Field_Array (T : Concrete_Type) is |
| First_Time : Boolean := True; |
| begin |
| for F in First_Field (Root) .. Last_Field (Root) loop |
| if Fields_Per_Node (T) (F) then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, F_Image (F)); |
| end if; |
| end loop; |
| end Put_Field_Array; |
| |
| Field_Enum_Type_Name : constant String := |
| (case Root is |
| when Node_Kind => "Node_Field", |
| when others => "Entity_Field"); -- Entity_Kind |
| |
| begin |
| Put (S, "-- Table of sizes in 32-bit slots for given " & |
| Image (Root) & ", for use by Atree:" & LF); |
| |
| case Root is |
| when Node_Kind => |
| Put (S, LF & "Min_Node_Size : constant Field_Offset := " & |
| Image (Min_Node_Size) & ";" & LF); |
| Put (S, "Max_Node_Size : constant Field_Offset := " & |
| Image (Max_Node_Size) & ";" & LF & LF); |
| Put (S, "Average_Node_Size_In_Slots : constant := " & |
| Average_Node_Size_In_Slots'Img & ";" & LF & LF); |
| when Entity_Kind => |
| Put (S, LF & "Min_Entity_Size : constant Field_Offset := " & |
| Image (Min_Entity_Size) & ";" & LF); |
| Put (S, "Max_Entity_Size : constant Field_Offset := " & |
| Image (Max_Entity_Size) & ";" & LF & LF); |
| when others => raise Program_Error; |
| end case; |
| |
| Put (S, "Size : constant array (" & Image (Root) & |
| ") of Field_Offset :=" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| |
| Iterate_Types (Root, Pre => Put_Size'Access); |
| |
| Decrease_Indent (S, 1); |
| 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); |
| |
| Put (S, "type " & Field_Enum_Type_Name & " 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 |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, F_Image (F)); |
| end loop; |
| |
| Decrease_Indent (S, 1); |
| Put (S, "); -- " & Field_Enum_Type_Name & LF); |
| Decrease_Indent (S, 2); |
| end; |
| |
| Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF); |
| Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" & |
| Field_Enum_Type_Name & "_Index range <>) of " & |
| Field_Enum_Type_Name & ";" & LF); |
| Put (S, "type " & Field_Enum_Type_Name & |
| "_Array_Ref is access constant " & Field_Enum_Type_Name & |
| "_Array;" & LF); |
| Put (S, "subtype A is " & Field_Enum_Type_Name & "_Array;" & LF); |
| -- Short name to make allocators below more readable |
| |
| declare |
| First_Time : Boolean := True; |
| |
| procedure Do_One_Type (T : Node_Or_Entity_Type); |
| procedure Do_One_Type (T : Node_Or_Entity_Type) is |
| begin |
| if T in Concrete_Type then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T) & " =>" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "new A'("); |
| Increase_Indent (S, 6); |
| Increase_Indent (S, 1); |
| |
| Put_Field_Array (T); |
| |
| Decrease_Indent (S, 1); |
| Put (S, ")"); |
| Decrease_Indent (S, 6); |
| Decrease_Indent (S, 2); |
| end if; |
| end Do_One_Type; |
| begin |
| Put (S, LF & "-- Table mapping " & Image (Root) & |
| "s to the sequence of fields that exist in that " & |
| Image (Root) & ":" & LF & LF); |
| |
| Put (S, Field_Enum_Type_Name & "_Table : constant array (" & |
| Image (Root) & ") of " & Field_Enum_Type_Name & |
| "_Array_Ref :=" & LF); |
| |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| |
| Iterate_Types (Root, Pre => Do_One_Type'Access); |
| |
| Decrease_Indent (S, 1); |
| Put (S, "); -- " & Field_Enum_Type_Name & "_Table" & LF); |
| Decrease_Indent (S, 2); |
| end; |
| |
| 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); |
| |
| 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; |
| |
| 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 Put_Tables; |
| |
| ---------------- |
| -- Put_Seinfo -- |
| ---------------- |
| |
| procedure Put_Seinfo is |
| S : Sink; |
| begin |
| Create_File (S, "seinfo.ads"); |
| Put (S, "with Types; use Types;" & LF); |
| Put (S, LF & "package Seinfo is" & LF & LF); |
| Increase_Indent (S, 3); |
| |
| Put (S, "-- This package is automatically generated." & LF & LF); |
| |
| Put (S, "-- Common declarations visible in both Sinfo.Nodes and Einfo.Entities." & LF); |
| |
| Put (S, LF & "type Field_Kind is" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| |
| declare |
| First_Time : Boolean := True; |
| begin |
| for T in Special_Type loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T) & "_Field"); |
| end loop; |
| end; |
| |
| Decrease_Indent (S, 1); |
| Decrease_Indent (S, 2); |
| Put (S, ");" & LF); |
| |
| Put (S, LF & "Field_Size : constant array (Field_Kind) of Field_Size_In_Bits :=" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "("); |
| Increase_Indent (S, 1); |
| |
| declare |
| First_Time : Boolean := True; |
| begin |
| for T in Special_Type loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, "," & LF); |
| end if; |
| |
| Put (S, Image (T) & "_Field => " & Image (Field_Size (T))); |
| end loop; |
| end; |
| |
| Decrease_Indent (S, 1); |
| Decrease_Indent (S, 2); |
| Put (S, ");" & LF & LF); |
| |
| Put (S, "type Field_Descriptor is record" & LF); |
| Increase_Indent (S, 3); |
| Put (S, "Kind : Field_Kind;" & LF); |
| Put (S, "Offset : Field_Offset;" & LF); |
| Decrease_Indent (S, 3); |
| Put (S, "end record;" & LF); |
| |
| Decrease_Indent (S, 3); |
| Put (S, LF & "end Seinfo;" & LF); |
| end Put_Seinfo; |
| |
| --------------- |
| -- Put_Nodes -- |
| --------------- |
| |
| procedure Put_Nodes 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"); |
| Put (S, "with Seinfo; use Seinfo;" & LF); |
| Put (S, "pragma Warnings (Off);" & LF); |
| -- With's included in case they are needed; so we don't have to keep |
| -- switching back and forth. |
| Put (S, "with Output; use Output;" & LF); |
| Put (S, "pragma Warnings (On);" & LF); |
| |
| Put (S, LF & "package Sinfo.Nodes is" & LF & LF); |
| Increase_Indent (S, 3); |
| |
| Put (S, "-- This package is automatically generated." & LF & LF); |
| |
| Put_Type_Hierarchy (S, Node_Kind); |
| |
| Put_Type_And_Subtypes (S, Node_Kind); |
| |
| Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);" & LF & LF); |
| Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);" & LF & LF); |
| |
| Put_Subp_Decls (S, Node_Kind); |
| |
| Put_Traversed_Fields (S); |
| |
| Put_Tables (S, Node_Kind); |
| |
| Decrease_Indent (S, 3); |
| Put (S, LF & "end Sinfo.Nodes;" & LF); |
| |
| Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF); |
| Put (B, "with Nlists; use Nlists;" & LF); |
| Put (B, "pragma Warnings (Off);" & LF); |
| Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF); |
| Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF); |
| Put (B, "pragma Warnings (On);" & LF); |
| |
| Put (B, LF & "package body Sinfo.Nodes is" & LF & LF); |
| Increase_Indent (B, 3); |
| |
| 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); |
| end if; |
| end loop; |
| |
| Put_Setter_With_Parent ("Node"); |
| Put_Setter_With_Parent ("List"); |
| |
| Put_Subp_Bodies (B, Node_Kind); |
| |
| Decrease_Indent (B, 3); |
| Put (B, "end Sinfo.Nodes;" & LF); |
| |
| end Put_Nodes; |
| |
| ------------------ |
| -- Put_Entities -- |
| ------------------ |
| |
| procedure Put_Entities is |
| S : Sink; |
| B : Sink; |
| 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); |
| Increase_Indent (S, 3); |
| |
| Put (S, "-- This package is automatically generated." & LF & LF); |
| |
| Put_Type_Hierarchy (S, Entity_Kind); |
| |
| Put_Type_And_Subtypes (S, Entity_Kind); |
| |
| Put_Subp_Decls (S, Entity_Kind); |
| |
| Put_Tables (S, Entity_Kind); |
| |
| Decrease_Indent (S, 3); |
| Put (S, LF & "end Einfo.Entities;" & LF); |
| |
| Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF); |
| Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF); |
| -- This forms a cycle between packages (via bodies, which is OK) |
| |
| Put (B, LF & "package body Einfo.Entities is" & LF & LF); |
| Increase_Indent (B, 3); |
| |
| 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); |
| end if; |
| end loop; |
| |
| Put_Subp_Bodies (B, Entity_Kind); |
| |
| Decrease_Indent (B, 3); |
| Put (B, "end Einfo.Entities;" & LF); |
| |
| end Put_Entities; |
| |
| ------------------- |
| -- Put_Make_Spec -- |
| ------------------- |
| |
| procedure Put_Make_Spec |
| (S : in out Sink; Root : Root_Type; T : Concrete_Type) |
| is |
| begin |
| Put (S, "function Make_" & Image_Sans_N (T) & "" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "(Sloc : Source_Ptr"); |
| Increase_Indent (S, 1); |
| |
| for F of Type_Table (T).Fields loop |
| pragma Assert (Fields_Per_Node (T) (F)); |
| |
| if Syntactic (T) (F) then |
| declare |
| Typ : constant String := |
| (if Field_Table (F).Field_Type = Flag then "Boolean" |
| else Image (Field_Table (F).Field_Type)); |
| |
| -- All Flag fields have a default, which is False by |
| -- default. |
| |
| Default : constant String := |
| (if Field_Table (F).Default_Value = No_Default then |
| (if Field_Table (F).Field_Type = Flag then " := False" else "") |
| else " := " & Value_Image (Field_Table (F).Default_Value)); |
| |
| begin |
| Put (S, ";" & LF); |
| Put (S, Image (F)); |
| Put (S, " : " & Typ & Default); |
| end; |
| end if; |
| end loop; |
| |
| Put (S, ")" & LF & "return " & Node_Or_Entity (Root) & "_Id"); |
| Decrease_Indent (S, 2); |
| Decrease_Indent (S, 1); |
| end Put_Make_Spec; |
| |
| -------------------- |
| -- Put_Make_Decls -- |
| -------------------- |
| |
| procedure Put_Make_Decls (S : in out Sink; Root : Root_Type) is |
| begin |
| for T in First_Concrete (Root) .. Last_Concrete (Root) loop |
| if T not in N_Unused_At_Start | N_Unused_At_End then |
| Put_Make_Spec (S, Root, T); |
| Put (S, ";" & LF & "pragma " & Inline & " (Make_" & |
| Image_Sans_N (T) & ");" & LF & LF); |
| end if; |
| end loop; |
| end Put_Make_Decls; |
| |
| --------------------- |
| -- Put_Make_Bodies -- |
| --------------------- |
| |
| procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type) is |
| begin |
| for T in First_Concrete (Root) .. Last_Concrete (Root) loop |
| if T not in N_Unused_At_Start | N_Unused_At_End then |
| Put_Make_Spec (S, Root, T); |
| Put (S, LF & "is" & LF); |
| |
| Increase_Indent (S, 3); |
| Put (S, "N : constant Node_Id :=" & LF); |
| |
| if T in Entity_Node then |
| Put (S, " New_Entity (" & Image (T) & ", Sloc);" & LF); |
| |
| else |
| Put (S, " New_Node (" & Image (T) & ", Sloc);" & LF); |
| end if; |
| |
| Decrease_Indent (S, 3); |
| |
| Put (S, "begin" & LF); |
| |
| Increase_Indent (S, 3); |
| for F of Type_Table (T).Fields loop |
| pragma Assert (Fields_Per_Node (T) (F)); |
| |
| if Syntactic (T) (F) then |
| declare |
| NWidth : constant := 28; |
| -- This constant comes from the old Xnmake, which wraps |
| -- the Set_... call if the field name is that long or |
| -- longer. |
| |
| F_Name : constant String := Image (F); |
| |
| begin |
| if F_Name'Length < NWidth then |
| Put (S, "Set_" & F_Name & " (N, " & F_Name & ");" & LF); |
| |
| -- Wrap the line |
| |
| else |
| Put (S, "Set_" & F_Name & "" & LF); |
| Increase_Indent (S, 2); |
| Put (S, "(N, " & F_Name & ");" & LF); |
| Decrease_Indent (S, 2); |
| end if; |
| end; |
| end if; |
| end loop; |
| |
| if Is_Descendant (N_Op, T) then |
| -- Special cases for N_Op nodes: fill in the Chars and Entity |
| -- fields even though they were not passed in. |
| |
| declare |
| Op : constant String := Image_Sans_N (T); |
| -- This will be something like "Op_And" or "Op_Add" |
| |
| Op_Name_With_Op : constant String := |
| (if T = N_Op_Plus then "Op_Add" |
| elsif T = N_Op_Minus then "Op_Subtract" |
| else Op); |
| -- Special cases for unary operators that have the same name |
| -- as a binary operator; we use the binary operator name in |
| -- that case. |
| |
| Slid : constant String (1 .. Op_Name_With_Op'Length) := |
| Op_Name_With_Op; |
| pragma Assert (Slid (1 .. 3) = "Op_"); |
| |
| Op_Name : constant String := |
| (if T in N_Op_Rotate_Left | |
| N_Op_Rotate_Right | |
| N_Op_Shift_Left | |
| N_Op_Shift_Right | |
| N_Op_Shift_Right_Arithmetic |
| then Slid (4 .. Slid'Last) |
| else Slid); |
| -- Special cases for shifts and rotates; the node kind has |
| -- "Op_", but the Name_Id constant does not. |
| |
| begin |
| Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF); |
| Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF); |
| end; |
| end if; |
| |
| if Type_Table (T).Nmake_Assert.all /= "" then |
| Put (S, "pragma Assert (" & |
| Type_Table (T).Nmake_Assert.all & ");" & LF); |
| end if; |
| |
| Put (S, "return N;" & LF); |
| Decrease_Indent (S, 3); |
| |
| Put (S, "end Make_" & Image_Sans_N (T) & ";" & LF & LF); |
| end if; |
| end loop; |
| end Put_Make_Bodies; |
| |
| --------------- |
| -- Put_Nmake -- |
| --------------- |
| |
| -- Documentation for the Nmake package, generated by Put_Nmake below. |
| |
| -- The Nmake package contains a set of routines used to construct tree |
| -- nodes using a functional style. There is one routine for each node |
| -- type defined in Gen_IL.Gen.Gen_Nodes with the general interface: |
| |
| -- function Make_xxx (Sloc : Source_Ptr, |
| -- Field_Name_1 : Field_Name_1_Type [:= default] |
| -- Field_Name_2 : Field_Name_2_Type [:= default] |
| -- ...) |
| -- return Node_Id |
| |
| -- Only syntactic fields are included. |
| |
| -- Default values are provided as specified in Gen_Nodes, except that if |
| -- no default is specified for a flag field, it has a default of False. |
| |
| -- Warning: since calls to Make_xxx routines are normal function calls, the |
| -- arguments can be evaluated in any order. This means that at most one such |
| -- argument can have side effects (e.g. be a call to a parse routine). |
| |
| procedure Put_Nmake is |
| S : Sink; |
| B : Sink; |
| |
| begin |
| Create_File (S, "nmake.ads"); |
| Create_File (B, "nmake.adb"); |
| Put (S, "with Namet; use Namet;" & LF); |
| Put (S, "with Nlists; use Nlists;" & LF); |
| Put (S, "with Types; use Types;" & LF); |
| Put (S, "with Uintp; use Uintp;" & LF); |
| Put (S, "with Urealp; use Urealp;" & LF); |
| |
| Put (S, LF & "package Nmake is" & LF & LF); |
| Increase_Indent (S, 3); |
| |
| Put (S, "-- This package is automatically generated." & LF & LF); |
| Put (S, "-- See Put_Nmake in gen_il-gen.adb for documentation." & LF & LF); |
| |
| Put_Make_Decls (S, Node_Kind); |
| |
| Decrease_Indent (S, 3); |
| Put (S, "end Nmake;" & LF); |
| |
| Put (B, "with Atree; use Atree;" & LF); |
| Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF); |
| Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF); |
| Put (B, "with Snames; use Snames;" & LF); |
| Put (B, "with Stand; use Stand;" & LF); |
| |
| Put (B, LF & "package body Nmake is" & LF & LF); |
| Increase_Indent (B, 3); |
| |
| Put (B, "-- This package is automatically generated." & LF & LF); |
| Put (B, "pragma Style_Checks (""M200"");" & LF); |
| |
| Put_Make_Bodies (B, Node_Kind); |
| |
| Decrease_Indent (B, 3); |
| Put (B, "end Nmake;" & LF); |
| end Put_Nmake; |
| |
| ----------------------- |
| -- Put_Seinfo_Tables -- |
| ----------------------- |
| |
| procedure Put_Seinfo_Tables is |
| S : Sink; |
| B : Sink; |
| |
| Type_Layout : Concrete_Type_Layout_Array; |
| |
| function Get_Last_Bit |
| (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset) |
| return Bit_Offset; |
| function First_Bit_Image (First_Bit : Bit_Offset) return String; |
| function Last_Bit_Image (Last_Bit : Bit_Offset) return String; |
| |
| procedure Put_Field_List (Bit : Bit_Offset); |
| -- Print out the list of fields that are allocated (in part, for |
| -- fields bigger than one bit) at the given bit offset. This allows |
| -- us to see which fields are overlaid with each other, which should |
| -- only happen if the sets of types with those fields are disjoint. |
| |
| function Get_Last_Bit |
| (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset) |
| return Bit_Offset is |
| begin |
| 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. |
| |
| Result := First_Bit; |
| |
| while (Result + 1) mod 32 /= 0 |
| and then Type_Layout (T) (Result + 1) = No_Field |
| loop |
| Result := Result + 1; |
| end loop; |
| |
| else |
| Result := First_Bit + Field_Size (F) - 1; |
| end if; |
| end return; |
| 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); |
| begin |
| return |
| Image (W) & "*32" & (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; |
| begin |
| if W * 32 - 1 = Last_Bit then |
| return Image (W) & "*32 - 1"; |
| else |
| return First_Bit_Image (Last_Bit); |
| end if; |
| end Last_Bit_Image; |
| |
| function Image_Or_Waste (F : Opt_Field_Enum) return String is |
| (if F = No_Field then "Wasted_Bits" else Image (F)); |
| |
| Num_Wasted_Bits : Bit_Offset'Base := 0; |
| |
| Type_Layout_Size : Bit_Offset'Base := Type_Layout'Size; |
| -- Total size of Type_Layout, including the Field_Arrays its |
| -- components point to. |
| |
| procedure Put_Field_List (Bit : Bit_Offset) is |
| First_Time : Boolean := True; |
| begin |
| for F in Field_Enum loop |
| if F /= Between_Node_And_Entity_Fields |
| and then Bit in First_Bit (F, Field_Table (F).Offset) |
| .. Last_Bit (F, Field_Table (F).Offset) |
| then |
| if First_Time then |
| First_Time := False; |
| else |
| Put (B, "," & LF); |
| end if; |
| |
| Put (B, Image (F)); |
| end if; |
| end loop; |
| end Put_Field_List; |
| |
| begin -- Put_Seinfo_Tables |
| Create_File (S, "seinfo_tables.ads"); |
| Create_File (B, "seinfo_tables.adb"); |
| |
| for T in Concrete_Type loop |
| Type_Layout (T) := new Field_Array' |
| (0 .. Type_Bit_Size_Aligned (T) - 1 => No_Field); |
| Type_Layout_Size := Type_Layout_Size + Type_Layout (T).all'Size; |
| |
| for F in Field_Enum loop |
| if Fields_Per_Node (T) (F) then |
| declare |
| Off : constant Field_Offset := Field_Table (F).Offset; |
| subtype Bit_Range is Bit_Offset |
| range First_Bit (F, Off) .. Last_Bit (F, Off); |
| begin |
| pragma Assert |
| (Type_Layout (T) (Bit_Range) = (Bit_Range => No_Field)); |
| Type_Layout (T) (Bit_Range) := (others => F); |
| end; |
| end if; |
| end loop; |
| end loop; |
| |
| for T in Concrete_Type loop |
| for B in 0 .. Type_Bit_Size_Aligned (T) - 1 loop |
| if Type_Layout (T) (B) = No_Field then |
| Num_Wasted_Bits := Num_Wasted_Bits + 1; |
| end if; |
| end loop; |
| end loop; |
| |
| Put (S, LF & "package Seinfo_Tables is" & LF & LF); |
| Increase_Indent (S, 3); |
| |
| Put (S, "-- This package is automatically generated." & LF & LF); |
| |
| Put (S, "-- This package is not used by the compiler." & LF); |
| Put (S, "-- The body contains tables that are intended to be used by humans to" & LF); |
| Put (S, "-- help understand the layout of various data structures." & LF); |
| Put (S, "-- Search for ""--"" to find major sections of code." & LF & LF); |
| |
| Put (S, "pragma Elaborate_Body;" & LF); |
| |
| Decrease_Indent (S, 3); |
| Put (S, LF & "end Seinfo_Tables;" & LF); |
| |
| Put (B, "with Gen_IL.Types; use Gen_IL.Types;" & LF); |
| Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;" & LF); |
| Put (B, "with Gen_IL.Internals; use Gen_IL.Internals;" & LF); |
| |
| Put (B, LF & "package body Seinfo_Tables is" & LF & LF); |
| Increase_Indent (B, 3); |
| |
| Put (B, "-- This package is automatically generated." & LF & LF); |
| |
| Put (B, "Num_Wasted_Bits : Bit_Offset'Base := " & Image (Num_Wasted_Bits) & |
| " with Unreferenced;" & LF); |
| |
| Put (B, LF & "Wasted_Bits : constant Opt_Field_Enum := No_Field;" & LF); |
| |
| Put (B, LF & "-- Table showing the layout of each Node_Or_Entity_Type. For each" & LF); |
| Put (B, "-- concrete type, we show the bits used by each field. Each field" & LF); |
| Put (B, "-- uses the same bit range in all types. This table is not used by" & LF); |
| Put (B, "-- the compiler; it is for information only." & LF & LF); |
| |
| Put (B, "-- Wasted_Bits are unused bits between fields, and padding at the end" & LF); |
| Put (B, "-- to round up to a multiple of the slot size." & LF); |
| |
| Put (B, LF & "-- Type_Layout is " & Image (Type_Layout_Size / 8) & " bytes." & LF); |
| |
| Put (B, LF & "pragma Style_Checks (Off);" & LF); |
| Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := " & LF); |
| Increase_Indent (B, 2); |
| Put (B, "-- Concrete node types:" & LF); |
| Put (B, "("); |
| Increase_Indent (B, 1); |
| |
| declare |
| First_Time : Boolean := True; |
| begin |
| for T in Concrete_Type loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (B, "," & LF & LF); |
| end if; |
| |
| if T = Concrete_Entity'First then |
| Put (B, "-- Concrete entity types:" & LF & LF); |
| end if; |
| |
| Put (B, Image (T) & " => new Field_Array'" & LF); |
| |
| Increase_Indent (B, 2); |
| Put (B, "("); |
| Increase_Indent (B, 1); |
| |
| declare |
| First_Time : Boolean := True; |
| First_Bit : Bit_Offset := 0; |
| begin |
| while First_Bit < Type_Bit_Size_Aligned (T) loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (B, "," & LF); |
| end if; |
| |
| declare |
| F : constant Opt_Field_Enum := |
| Type_Layout (T) (First_Bit); |
| begin |
| declare |
| Last_Bit : constant Bit_Offset := |
| Get_Last_Bit (T, F, First_Bit); |
| begin |
| pragma Assert |
| (Type_Layout (T) (First_Bit .. Last_Bit) = |
| (First_Bit .. Last_Bit => F)); |
| |
| if Last_Bit = First_Bit then |
| Put (B, First_Bit_Image (First_Bit) & " => " & |
| Image_Or_Waste (F)); |
| else |
| pragma Assert |
| (if F /= No_Field then |
| First_Bit mod Field_Size (F) = 0); |
| Put (B, First_Bit_Image (First_Bit) & " .. " & |
| Last_Bit_Image (Last_Bit) & " => " & |
| Image_Or_Waste (F)); |
| end if; |
| |
| First_Bit := Last_Bit + 1; |
| end; |
| end; |
| end loop; |
| end; |
| |
| Decrease_Indent (B, 1); |
| Put (B, ")"); |
| Decrease_Indent (B, 2); |
| end loop; |
| end; |
| |
| Decrease_Indent (B, 1); |
| Put (B, ") -- Type_Layout" & LF); |
| Increase_Indent (B, 6); |
| Put (B, "with Export, Convention => Ada;" & LF); |
| Decrease_Indent (B, 6); |
| Decrease_Indent (B, 2); |
| |
| Put (B, LF & "-- Table mapping bit offsets to the set of fields at that offset" & LF & LF); |
| Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=" & LF); |
| |
| Increase_Indent (B, 2); |
| Put (B, "("); |
| Increase_Indent (B, 1); |
| |
| declare |
| First_Time : Boolean := True; |
| begin |
| for Bit in 0 .. Bit_Offset'Max |
| (Max_Node_Bit_Size, Max_Entity_Bit_Size) |
| loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (B, "," & LF & LF); |
| end if; |
| |
| Put (B, First_Bit_Image (Bit) & " => new Field_Array'" & LF); |
| |
| -- Use [...] notation here, to get around annoying Ada |
| -- limitations on empty and singleton aggregates. This code is |
| -- not used in the compiler, so there are no bootstrap issues. |
| |
| Increase_Indent (B, 2); |
| Put (B, "["); |
| Increase_Indent (B, 1); |
| |
| Put_Field_List (Bit); |
| |
| Decrease_Indent (B, 1); |
| Put (B, "]"); |
| Decrease_Indent (B, 2); |
| end loop; |
| end; |
| |
| Decrease_Indent (B, 1); |
| Put (B, "); -- Bit_Used" & LF); |
| Decrease_Indent (B, 2); |
| |
| Decrease_Indent (B, 3); |
| Put (B, LF & "end Seinfo_Tables;" & LF); |
| |
| end Put_Seinfo_Tables; |
| |
| ----------------------------- |
| -- Put_C_Type_And_Subtypes -- |
| ----------------------------- |
| |
| procedure Put_C_Type_And_Subtypes |
| (S : in out Sink; Root : Root_Type) is |
| |
| Cur_Pos : Root_Nat := 0; |
| -- Current Node_Kind'Pos or Entity_Kind'Pos to be printed |
| |
| procedure Put_Enum_Lit (T : Node_Or_Entity_Type); |
| -- Print out the #define corresponding to the Ada enumeration literal |
| -- for T in Node_Kind and Entity_Kind (i.e. concrete types). |
| -- This looks like "#define Some_Kind <pos>", where Some_Kind |
| -- is the Node_Kind or Entity_Kind enumeration literal, and |
| -- <pos> is Node_Kind'Pos or Entity_Kind'Pos of that literal. |
| |
| procedure Put_Kind_Subtype (T : Node_Or_Entity_Type); |
| -- Print out the SUBTYPE macro call corresponding to an abstract |
| -- type. |
| |
| procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is |
| begin |
| if T in Concrete_Type then |
| Put (S, "#define " & Image (T) & " " & Image (Cur_Pos) & LF); |
| Cur_Pos := Cur_Pos + 1; |
| end if; |
| end Put_Enum_Lit; |
| |
| procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is |
| begin |
| if T in Abstract_Type and then Type_Table (T).Parent /= No_Type then |
| Put (S, "SUBTYPE (" & Image (T) & ", " & |
| Image (Type_Table (T).Parent) & "," & LF); |
| Increase_Indent (S, 3); |
| Put (S, Image (Type_Table (T).First) & "," & LF); |
| Put (S, Image (Type_Table (T).Last) & ")" & LF); |
| Decrease_Indent (S, 3); |
| end if; |
| end Put_Kind_Subtype; |
| |
| begin |
| Iterate_Types (Root, Pre => Put_Enum_Lit'Access); |
| |
| Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " & |
| Image (Cur_Pos) & "" & LF & LF); |
| |
| Iterate_Types (Root, Pre => Put_Kind_Subtype'Access); |
| |
| Put_Union_Membership (S, Root); |
| end Put_C_Type_And_Subtypes; |
| |
| ---------------------------- |
| -- Put_Low_Level_C_Getter -- |
| ---------------------------- |
| |
| procedure Put_Low_Level_C_Getter |
| (S : in out Sink; T : Type_Enum) |
| is |
| T_Image : constant String := Get_Set_Id_Image (T); |
| |
| begin |
| Put (S, "INLINE " & T_Image & "" & LF); |
| Put (S, "Get_" & Image (T) & " (Node_Id N, Field_Offset Offset)" & LF); |
| |
| Increase_Indent (S, 3); |
| |
| -- 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); |
| |
| 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); |
| |
| else |
| Put (S, "{ return (" & T_Image & ") Get_" & |
| Image (Field_Size (T)) & "_Bit_Field(N, Offset); }" & LF & LF); |
| end if; |
| |
| Decrease_Indent (S, 3); |
| end Put_Low_Level_C_Getter; |
| |
| ----------------------------- |
| -- Put_High_Level_C_Getter -- |
| ----------------------------- |
| |
| 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); |
| |
| 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); |
| Decrease_Indent (S, 3); |
| end Put_High_Level_C_Getter; |
| |
| ------------------------------ |
| -- Put_High_Level_C_Getters -- |
| ------------------------------ |
| |
| procedure Put_High_Level_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); |
| end loop; |
| end Put_High_Level_C_Getters; |
| |
| -------------------------- |
| -- Put_Union_Membership -- |
| -------------------------- |
| |
| procedure Put_Union_Membership |
| (S : in out Sink; Root : Root_Type) is |
| |
| procedure Put_Ors (T : Abstract_Type); |
| -- Print the "or" (i.e. "||") of tests whether kind is in each child |
| -- type. |
| |
| procedure Put_Ors (T : Abstract_Type) is |
| First_Time : Boolean := True; |
| begin |
| for Child of Type_Table (T).Children loop |
| if First_Time then |
| First_Time := False; |
| else |
| Put (S, " ||" & LF); |
| end if; |
| |
| -- Unions, other abstract types, and concrete types each have |
| -- their own way of testing membership in the C++ code. |
| |
| if Child in Abstract_Type then |
| if Type_Table (Child).Is_Union then |
| Put (S, "Is_In_" & Image (Child) & " (kind)"); |
| |
| else |
| Put (S, "IN (kind, " & Image (Child) & ")"); |
| end if; |
| |
| else |
| Put (S, "kind == " & Image (Child)); |
| end if; |
| end loop; |
| end Put_Ors; |
| |
| begin |
| Put (S, LF & "// Membership tests for union types" & LF & LF); |
| |
| for T in First_Abstract (Root) .. Last_Abstract (Root) loop |
| if Type_Table (T) /= null and then Type_Table (T).Is_Union then |
| Put (S, "INLINE Boolean" & LF); |
| Put (S, "Is_In_" & Image (T) & " (" & |
| Node_Or_Entity (Root) & "_Kind kind)" & LF); |
| |
| Put (S, "{" & LF); |
| Increase_Indent (S, 3); |
| Put (S, "return" & LF); |
| Increase_Indent (S, 3); |
| Put_Ors (T); |
| Decrease_Indent (S, 3); |
| Decrease_Indent (S, 3); |
| Put (S, ";" & LF & "}" & LF); |
| |
| Put (S, "" & LF); |
| end if; |
| end loop; |
| end Put_Union_Membership; |
| |
| --------------------- |
| -- Put_Sinfo_Dot_H -- |
| --------------------- |
| |
| procedure Put_Sinfo_Dot_H is |
| S : Sink; |
| |
| begin |
| Create_File (S, "sinfo.h"); |
| Put (S, "#ifdef __cplusplus" & LF); |
| Put (S, "extern ""C"" {" & LF); |
| Put (S, "#endif" & LF & LF); |
| |
| Put (S, "typedef Boolean Flag;" & 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 (S, "#ifdef __cplusplus" & LF); |
| Put (S, "}" & LF); |
| Put (S, "#endif" & LF); |
| end Put_Sinfo_Dot_H; |
| |
| --------------------- |
| -- Put_Einfo_Dot_H -- |
| --------------------- |
| |
| procedure Put_Einfo_Dot_H is |
| S : Sink; |
| |
| procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type); |
| procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type); |
| -- Print out the Is_... function for T that calls the IN macro on the |
| -- SUBTYPE. |
| |
| procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type) is |
| Im : constant String := Image (T); |
| pragma Assert (Im (Im'Last - 4 .. Im'Last) = "_Kind"); |
| Im2 : constant String := Im (Im'First .. Im'Last - 5); |
| Typ : constant String := |
| (if Is_Descendant (Type_Kind, T) |
| and then T /= Type_Kind |
| then "_Type" |
| else ""); |
| begin |
| pragma Assert (not Type_Table (T).Is_Union); |
| |
| Put (S, "INLINE B Is_" & Im2 & Typ & " (E Id)"); |
| end Put_Membership_Query_Spec; |
| |
| procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type) is |
| begin |
| if T in Abstract_Type and T not in Root_Type then |
| Put_Membership_Query_Spec (T); |
| Put (S, "" & LF); |
| Increase_Indent (S, 3); |
| Put (S, "{ return IN (Ekind (Id), " & Image (T) & "); }" & LF); |
| Decrease_Indent (S, 3); |
| end if; |
| end Put_Membership_Query_Defn; |
| |
| begin |
| Create_File (S, "einfo.h"); |
| Put (S, "#ifdef __cplusplus" & LF); |
| Put (S, "extern ""C"" {" & LF); |
| Put (S, "#endif" & LF & LF); |
| |
| Put (S, "typedef Boolean Flag;" & LF & LF); |
| |
| Put_C_Type_And_Subtypes (S, Entity_Kind); |
| |
| -- Note that we do not call Put_Low_Level_C_Getter here. Those are in |
| -- sinfo.h, so every file that #includes einfo.h must #include |
| -- sinfo.h first. |
| |
| Put_High_Level_C_Getters (S, Entity_Kind); |
| |
| Put (S, "// Abstract type queries" & LF & LF); |
| |
| Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Defn'Access); |
| |
| Put (S, LF & "#ifdef __cplusplus" & LF); |
| Put (S, "}" & LF); |
| Put (S, "#endif" & LF); |
| end Put_Einfo_Dot_H; |
| |
| begin -- Compile |
| |
| Check_Completeness; |
| |
| Compute_Ranges (Node_Kind); |
| Compute_Ranges (Entity_Kind); |
| Compute_Fields_Per_Node; |
| Compute_Field_Offsets; |
| Compute_Type_Sizes; |
| Check_For_Syntactic_Field_Mismatch; |
| |
| Verify_Type_Table; |
| |
| Node_Field_Types_Used := |
| Field_Types_Used (Node_Field'First, Node_Field'Last); |
| Entity_Field_Types_Used := |
| Field_Types_Used (Entity_Field'First, Entity_Field'Last); |
| |
| Put_Seinfo; |
| |
| Put_Nodes; |
| |
| Put_Entities; |
| |
| Put_Nmake; |
| |
| Put_Seinfo_Tables; |
| |
| Put_Sinfo_Dot_H; |
| Put_Einfo_Dot_H; |
| |
| end Compile; |
| |
| -------- |
| -- Sy -- |
| -------- |
| |
| function Sy |
| (Field : Node_Field; |
| Field_Type : Type_Enum; |
| Default_Value : Field_Default_Value := No_Default; |
| Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is |
| begin |
| return |
| (1 => Create_Syntactic_Field |
| (Field, Field_Type, Default_Value, Pre, Pre_Get, Pre_Set)); |
| end Sy; |
| |
| -------- |
| -- Sm -- |
| -------- |
| |
| function Sm |
| (Field : Field_Enum; |
| Field_Type : Type_Enum; |
| Type_Only : Type_Only_Enum := No_Type_Only; |
| Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is |
| begin |
| return (1 => Create_Semantic_Field |
| (Field, Field_Type, Type_Only, Pre, Pre_Get, Pre_Set)); |
| end Sm; |
| |
| end Gen_IL.Gen; |