diff options
Diffstat (limited to 'gcc/ada/vast.adb')
| -rw-r--r-- | gcc/ada/vast.adb | 592 |
1 files changed, 586 insertions, 6 deletions
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index 302a89b..59470fd 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -23,18 +23,598 @@ -- -- ------------------------------------------------------------------------------ --- Dummy implementation +pragma Unsuppress (All_Checks); +pragma Assertion_Policy (Check); +-- Enable checking. This isn't really necessary, but it might come in handy if +-- we want to run VAST with a compiler built without checks. Anyway, it's +-- harmless, because VAST is not run by default. + +with Ada.Unchecked_Deallocation; + +with System.Case_Util; + +with Atree; use Atree; +with Debug; +with Einfo.Entities; use Einfo.Entities; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinput; +with Table; +with Types; use Types; package body VAST is + -- ???Basic tree properties not yet checked: + -- - No dangling trees. Every node that is reachable at all is reachable + -- by some syntactic path. + -- - Basic properties of Nlists/Elists (next/prev pointers make sense, + -- for example). + + Force_Enable_VAST : constant Boolean := False; + -- Normally, VAST is enabled by the the -gnatd_V switch. + -- To force it to be enabled independent of any switches, + -- set this to True. + + type Check_Enum is + (Check_Other, + Check_Sloc, + Check_Analyzed, + Check_Error_Nodes, + Check_Sharing, + Check_Parent_Present, + Check_Parent_Correct); + + type Check_Status is + -- Action in case of check failure: + (Disabled, -- Do nothing + Enabled, -- Print messages, and raise an exception + Print_And_Continue); -- Print a message + + pragma Warnings (Off, "Status*could be declared constant"); + Status : array (Check_Enum) of Check_Status := + (Check_Other => Enabled, + Check_Sloc => Disabled, + Check_Analyzed => Disabled, + Check_Error_Nodes => Print_And_Continue, + Check_Sharing => Disabled, + Check_Parent_Present => Print_And_Continue, + Check_Parent_Correct => Disabled); +-- others => Print_And_Continue); +-- others => Enabled); +-- others => Disabled); + -- Passing checks are Check_Other, which should always be Enabled. + -- Currently-failing checks are different enumerals in Check_Enum, + -- which can be disabled individually until we fix the bugs, or enabled + -- when debugging particular bugs. Pass a nondefault Check_Enum to + -- Assert in order to deal with bugs we have not yet fixed, + -- and play around with the value of Status above for + -- testing and debugging. + -- + -- Note: Once a bug is fixed, and the check passes reliably, we may choose + -- to remove that check from Check_Enum and use Check_Other instead. + + type Node_Stack_Index is new Pos; + subtype Node_Stack_Count is + Node_Stack_Index'Base range 0 .. Node_Stack_Index'Last; + + package Node_Stack is new Table.Table + (Table_Component_Type => Node_Id, + Table_Index_Type => Node_Stack_Index'Base, + Table_Low_Bound => 1, + Table_Initial => 1, + Table_Increment => 100, + Table_Name => "Node_Stack"); + + procedure Assert + (Condition : Boolean; + Check : Check_Enum := Check_Other; + Detail : String := ""); + -- Check that the Condition is True. Status determines action on failure. + + function To_Mixed (A : String) return String; + -- Copied from System.Case_Util; old versions of that package do not have + -- this function, so this is needed for bootstrapping. + + function Image (Kind : Node_Kind) return String is (To_Mixed (Kind'Img)); + function Image (Kind : Entity_Kind) return String is (To_Mixed (Kind'Img)); + + procedure Put (S : String); + procedure Put_Line (S : String); + procedure Put_Node (N : Node_Id); + procedure Put_Node_Stack; + -- Output routines; print only if -gnatd_W (VAST in verbose mode) is + -- enabled. + + procedure Put_Indentation; + -- Print spaces to indicate nesting depth of Node_Stack + + procedure Enter_Node (N : Node_Id); + procedure Leave_Node (N : Node_Id); + -- Called for each node while walking the tree. + -- Push/pop N to/from Node_Stack. + -- Print enter/leave debugging messages. + -- ???Possible improvements to messages: + -- Walk subtrees in a better order. + -- Print field names. + -- Don't print boring fields (such as N_Empty nodes). + -- Print more info (value of literals, "A.B.C" for expanded names, etc.). + -- Share some code with Treepr. + + procedure Do_Tree (N : Node_Id); + -- Do VAST checking on a tree of nodes + + function Has_Subtrees (N : Node_Id) return Boolean; + -- True if N has one or more syntactic fields + + procedure Do_Subtrees (N : Node_Id); + -- Call Do_Tree on all the subtrees (i.e. syntactic fields) of N + + procedure Do_List (L : List_Id); + -- Call Do_Tree on the list elements + + procedure Do_Unit (U : Unit_Number_Type); + -- Call Do_Tree on the root node of a compilation unit + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id; + -- Nth ancestor on the Node_Stack. Ancestor_Node(0) is the current node, + -- Ancestor_Node(1) is its parent, Ancestor_Node(2) is its grandparent, + -- and so on. + + function Top_Node return Node_Id is (Ancestor_Node (0)); + + type Node_Set is array (Node_Id range <>) of Boolean; + pragma Pack (Node_Set); + type Node_Set_Ptr is access all Node_Set; + procedure Free is new Ada.Unchecked_Deallocation (Node_Set, Node_Set_Ptr); + + Visited : Node_Set_Ptr; + -- Giant array of Booleans; Visited (N) is True if and only if we have + -- visited N in the tree walk. Used to detect incorrect sharing of subtrees + -- or (worse) cycles. We don't allocate the set on the stack, for fear of + -- Storage_Error. + + function Get_Node_Field_Union is new + Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; + + -------------- + -- To_Mixed -- + -------------- + + function To_Mixed (A : String) return String is + Result : String := A; + begin + System.Case_Util.To_Mixed (Result); + return Result; + end To_Mixed; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + if Debug.Debug_Flag_Underscore_WW then + Output.Write_Line (S); + end if; + end Put_Line; + + -------------- + -- Put_Node -- + -------------- + + procedure Put_Node (N : Node_Id) is + begin + if Debug.Debug_Flag_Underscore_WW then + if Nkind (N) in N_Entity then + Put (Image (Ekind (N))); + else + Put (Image (Nkind (N))); + end if; + + Put (N'Img & " "); + Sinput.Write_Location (Sloc (N)); + + if Comes_From_Source (N) then + Put (" (s)"); + end if; + + case Nkind (N) is + when N_Has_Chars => + Put (" "); + Write_Name_For_Debug (Chars (N), Quote => """"); + when others => null; + end case; + + end if; + end Put_Node; + + --------------------- + -- Put_Indentation -- + --------------------- + + procedure Put_Indentation is + begin + Put (String'(Natural (Node_Stack.First) .. + Natural (Node_Stack.Last) * 2 => ' ')); + end Put_Indentation; + + ---------------- + -- Enter_Node -- + ---------------- + + procedure Enter_Node (N : Node_Id) is + begin + Node_Stack.Append (N); -- push + + if Has_Subtrees (N) then + Put ("-->"); + else + -- If no subtrees, just print one line for enter/leave + Put (" "); + end if; + Put_Indentation; + Put_Node (N); + Put_Line (""); + end Enter_Node; + ---------------- - -- Check_Tree -- + -- Leave_Node -- ---------------- - procedure Check_Tree (GNAT_Root : Node_Id) is - pragma Unreferenced (GNAT_Root); + procedure Leave_Node (N : Node_Id) is + begin + if Has_Subtrees (N) then + Put ("<--"); + Put_Indentation; + Put_Node (N); + Put_Line (""); + end if; + + Node_Stack.Decrement_Last; -- pop + end Leave_Node; + + -------------------- + -- Put_Node_Stack -- + -------------------- + + procedure Put_Node_Stack is + begin + for J in reverse Node_Stack.First .. Node_Stack.Last loop + Put_Node (Node_Stack.Table (J)); + Put_Line (""); + end loop; + end Put_Node_Stack; + + ------------------- + -- Ancestor_Node -- + ------------------- + + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id is + begin + return Node_Stack.Table (Node_Stack.Last - Count); + end Ancestor_Node; + + ------------ + -- Assert -- + ------------ + + VAST_Failure : exception; + + procedure Assert + (Condition : Boolean; + Check : Check_Enum := Check_Other; + Detail : String := "") + is begin - null; - end Check_Tree; + if not Condition then + declare + Part1 : constant String := "VAST fail"; + Part2 : constant String := + (if Check = Check_Other then "" + else ": " & To_Mixed (Check'Img)); + Part3 : constant String := + (if Detail = "" then "" else " -- " & Detail); + Message : constant String := Part1 & Part2 & Part3; + Save : constant Boolean := Debug.Debug_Flag_Underscore_WW; + begin + case Status (Check) is + when Disabled => null; + when Enabled | Print_And_Continue => + Debug.Debug_Flag_Underscore_WW := True; + -- ???We should probably avoid changing the debug flag here + Put (Message & ": "); + Put_Node (Top_Node); + Put_Line (""); + + if Status (Check) = Enabled then + Put_Node_Stack; + raise VAST_Failure with Message; + end if; + + Debug.Debug_Flag_Underscore_WW := Save; + end case; + end; + end if; + end Assert; + + ------------- + -- Do_Tree -- + ------------- + + procedure Do_Tree (N : Node_Id) is + begin + Enter_Node (N); + + -- Skip the rest if empty. Check Sloc: + + case Nkind (N) is + when N_Empty => + Assert (No (Sloc (N))); + goto Done; -- --------------> + -- Don't do any further checks on Empty + + -- ???Some nodes, including exception handlers, have no Sloc; + -- it's unclear why. + + when N_Exception_Handler => + Assert (if Comes_From_Source (N) then Present (Sloc (N))); + when others => + Assert (Present (Sloc (N)), Check_Sloc); + end case; + + -- All reachable nodes should have been analyzed by the time we get + -- here: + + Assert (Analyzed (N), Check_Analyzed); + + -- If we visit the same node more than once, then there are shared + -- nodes; the "tree" is not a tree: + + Assert (not Visited (N), Check_Sharing); + Visited (N) := True; + + -- Misc checks based on node/entity kind: + + case Nkind (N) is + when N_Unused_At_Start | N_Unused_At_End => + Assert (False); + + when N_Error => + -- VAST doesn't do anything when Serious_Errors_Detected > 0 (at + -- least for now), so we shouldn't encounter any N_Error nodes. + Assert (False, Check_Error_Nodes); + + when N_Entity => + case Ekind (N) is + when others => + null; -- more to be done here + end case; + + when others => + null; -- more to be done here + end case; + + -- Check that N has a Parent, except in certain cases: + + case Nkind (N) is + when N_Empty => + raise Program_Error; -- can't get here + + when N_Error => + Assert (False, Check_Error_Nodes); + -- The error node has no parent, but we shouldn't even be seeing + -- error nodes in VAST at all. See earlier "when N_Error". + + when N_Compilation_Unit => + Assert (No (Parent (N))); + -- The parent of the root of each unit is empty. + + when N_Entity => + if not Is_Itype (N) then + -- An Itype might or might not have a parent + + Assert + (Present (Parent (N)), Detail => "missing parent of entity"); + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + + when others => + Assert (Present (Parent (N)), Check_Parent_Present); + -- All other nodes should have a parent + if Status (Check_Parent_Present) = Enabled then + Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); + end if; + end case; + + Do_Subtrees (N); + + <<Done>> + Leave_Node (N); + end Do_Tree; + + ----------------- + -- Has_Subtrees -- + ----------------- + + function Has_Subtrees (N : Node_Id) return Boolean is + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + -- True if sentinel comes first + return Offsets (Offsets'First) /= No_Field_Offset; + end Has_Subtrees; + + ----------------- + -- Do_Subtrees -- + ----------------- + + procedure Do_Subtrees (N : Node_Id) is + -- ???Do we need tail recursion elimination here, + -- as in Atree.Traverse_Func? + Offsets : Traversed_Offset_Array renames + Traversed_Fields (Nkind (N)); + begin + for Cur_Field in Offset_Array_Index loop + exit when Offsets (Cur_Field) = No_Field_Offset; + + declare + F : constant Union_Id := + Get_Node_Field_Union (N, Offsets (Cur_Field)); + begin + if F in Node_Range then + Do_Tree (Node_Id (F)); + elsif F in List_Range then + Do_List (List_Id (F)); + else + raise Program_Error; + end if; + end; + end loop; + end Do_Subtrees; + + ------------- + -- Do_List -- + ------------- + + procedure Do_List (L : List_Id) is + Elmt : Node_Id := First (L); + Len : constant String := List_Length (L)'Img; + begin + if Is_Non_Empty_List (L) then + Put ("-->"); + Put_Indentation; + Put_Line ("list len=" & Len); + + while Present (Elmt) loop + Do_Tree (Elmt); + Next (Elmt); + end loop; + + Put ("<--"); + Put_Indentation; + Put_Line ("list len=" & Len); + end if; + end Do_List; + + ------------- + -- Do_Unit -- + ------------- + + procedure Do_Unit (U : Unit_Number_Type) is + U_Name : constant Unit_Name_Type := Unit_Name (U); + U_Name_S : constant String := + (if U_Name = No_Unit_Name then "<No_Unit_Name>" + else Get_Name_String (U_Name)); + Predef : constant String := + (if Is_Predefined_Unit (U) then " (predef)" + elsif Is_Internal_Unit (U) then " (gnat)" + else ""); + Is_Main : constant String := + (if U = Main_Unit then " (main unit)" else ""); + Msg : constant String := + "VAST for unit" & U'Img & " " & U_Name_S & Predef & Is_Main; + + Is_Preprocessing_Dependency : constant Boolean := + U_Name = No_Unit_Name; + -- True if this is a bogus unit added by Add_Preprocessing_Dependency. + -- ???Not sure what that's about, but these units have no name and + -- no associated tree, so we had better not try to walk those trees. + + Root : constant Node_Id := Cunit (U); + begin + pragma Assert (Node_Stack.Last = 0); + Assert (No (Root) = Is_Preprocessing_Dependency); + -- All compilation units except these bogus ones should have a Cunit. + + Put_Line (Msg); + + if Is_Preprocessing_Dependency then + Put_Line ("Skipping preprocessing dependency"); + return; + end if; + + Assert (Present (Root)); + Do_Tree (Root); + Put_Line (Msg & " (done)"); + pragma Assert (Node_Stack.Last = 0); + end Do_Unit; + + ---------- + -- VAST -- + ---------- + + procedure VAST is + pragma Assert (Expander_Active = (Operating_Mode = Generate_Code)); + -- ???So why do we need both Operating_Mode and Expander_Active? + use Debug; + begin + -- Do nothing if we're not calling the back end; the main point of VAST + -- is to protect against code-generation bugs. This includes the + -- case where legality errors were detected; the tree is known to be + -- malformed in some error cases. + + if Operating_Mode /= Generate_Code then + return; + end if; + + -- If -gnatd_W (VAST in verbose mode) is enabled, then that should imply + -- -gnatd_V (enable VAST). + + if Debug_Flag_Underscore_WW then + Debug_Flag_Underscore_VV := True; + end if; + + -- Do nothing if VAST is disabled + + if not (Debug_Flag_Underscore_VV or Force_Enable_VAST) then + return; + end if; + + -- Turn off output unless verbose mode is enabled + + Put_Line ("VAST"); + + -- Operating_Mode = Generate_Code implies there are no legality errors: + + Assert (Serious_Errors_Detected = 0); + + Put_Line ("VAST checking" & Last_Unit'Img & " units"); + + declare + use Atree_Private_Part; + Last_Node : constant Node_Id := Node_Offsets.Last; + begin + pragma Assert (Visited = null); + Visited := new Node_Set'(Node_Id'First .. Last_Node => False); + + for U in Main_Unit .. Last_Unit loop + -- Main_Unit is the one passed to the back end, but here we are + -- walking all the units. + Do_Unit (U); + end loop; + + -- We shouldn't have allocated any new nodes during VAST: + + pragma Assert (Node_Offsets.Last = Last_Node); + Free (Visited); + end; + + Put_Line ("VAST done."); + end VAST; end VAST; |