diff options
Diffstat (limited to 'src/synth/elab-debugger__on.adb')
| -rw-r--r-- | src/synth/elab-debugger__on.adb | 1296 |
1 files changed, 1296 insertions, 0 deletions
diff --git a/src/synth/elab-debugger__on.adb b/src/synth/elab-debugger__on.adb new file mode 100644 index 000000000..608edbb07 --- /dev/null +++ b/src/synth/elab-debugger__on.adb @@ -0,0 +1,1296 @@ +-- Debugging during synthesis. +-- Copyright (C) 2019 Tristan Gingold +-- +-- This file is part of GHDL. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT 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 +-- along with this program. If not, see <gnu.org/licenses>. + +with System; + +with Types; use Types; +with Files_Map; +with Tables; +with Simple_IO; use Simple_IO; +with Utils_IO; use Utils_IO; +with Name_Table; +with Str_Table; +with Libraries; + +with Grt.Readline; + +with Vhdl.Errors; +with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk; +with Vhdl.Parse; +with Vhdl.Utils; use Vhdl.Utils; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Context.Debug; use Elab.Vhdl_Context.Debug; + +package body Elab.Debugger is + Flag_Enabled : Boolean := False; + + Current_Instance : Synth_Instance_Acc; + Current_Loc : Node; + + type Debug_Reason is + ( + Reason_Init, + Reason_Break, + Reason_Error + ); + + package Breakpoints is new Tables + (Table_Index_Type => Natural, + Table_Component_Type => Node, + Table_Low_Bound => 1, + Table_Initial => 16); + + function Is_Breakpoint_Hit return Boolean is + begin + for I in Breakpoints.First .. Breakpoints.Last loop + if Breakpoints.Table (I) = Current_Loc then + return True; + end if; + end loop; + return False; + end Is_Breakpoint_Hit; + + -- Current execution state, or reason to stop execution (set by the + -- last debugger command). + type Exec_State_Type is + (-- Execution should continue until a breakpoint is reached or assertion + -- failure. + Exec_Run, + + -- Execution will stop at the next statement. + Exec_Single_Step, + + -- Execution will stop at the next simple statement in the same frame. + Exec_Next, + + -- Execution will stop at the next statement in the same frame. In + -- case of compound statement, stop after the compound statement. + Exec_Next_Stmt); + + Exec_State : Exec_State_Type := Exec_Run; + + -- Current frame for next. + Exec_Instance : Synth_Instance_Acc; + + -- Current statement for next_stmt. + Exec_Statement : Node; + + function Is_Within_Statement (Stmt : Node; Cur : Node) return Boolean + is + Parent : Node; + begin + Parent := Cur; + loop + if Parent = Stmt then + return True; + end if; + case Get_Kind (Parent) is + when Iir_Kinds_Sequential_Statement => + Parent := Get_Parent (Parent); + when others => + return False; + end case; + end loop; + end Is_Within_Statement; + + Prompt_Debug : constant String := "debug> " & ASCII.NUL; + Prompt_Error : constant String := "error> " & ASCII.NUL; + Prompt_Init : constant String := "init> " & ASCII.NUL; + -- Prompt_Elab : constant String := "elab> " & ASCII.NUL; + + procedure Disp_Iir_Location (N : Node) is + begin + if N = Null_Iir then + Put_Err ("??:??:??"); + else + Put_Err (Vhdl.Errors.Disp_Location (N)); + end if; + Put_Err (": "); + end Disp_Iir_Location; + + -- For the list command: current file and current line. + List_Current_File : Source_File_Entry := No_Source_File_Entry; + List_Current_Line : Natural := 0; + List_Current_Line_Pos : Source_Ptr := 0; + + -- Set List_Current_* from a location. To be called after program break + -- to indicate current location. + procedure Set_List_Current (Loc : Location_Type) + is + Offset : Natural; + begin + Files_Map.Location_To_Coord + (Loc, List_Current_File, List_Current_Line_Pos, + List_Current_Line, Offset); + end Set_List_Current; + + procedure Disp_Current_Lines + is + use Files_Map; + -- Number of lines to display before and after the current line. + Radius : constant := 5; + + Buf : File_Buffer_Acc; + + Pos : Source_Ptr; + Line : Natural; + Len : Source_Ptr; + C : Character; + begin + if List_Current_Line > Radius then + Line := List_Current_Line - Radius; + else + Line := 1; + end if; + + Pos := File_Line_To_Position (List_Current_File, Line); + Buf := Get_File_Source (List_Current_File); + + while Line < List_Current_Line + Radius loop + -- Compute line length. + Len := 0; + loop + C := Buf (Pos + Len); + exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; + Len := Len + 1; + end loop; + + -- Disp line number. + declare + Str : constant String := Natural'Image (Line); + begin + if Line = List_Current_Line then + Put ('*'); + else + Put (' '); + end if; + Put ((Str'Length .. 5 => ' ')); + Put (Str (Str'First + 1 .. Str'Last)); + Put (' '); + end; + + -- Disp line. + Put_Line (String (Buf (Pos .. Pos + Len - 1))); + + -- Skip EOL. + exit when C = ASCII.EOT; + Pos := Pos + Len + 1; + if C = ASCII.CR then + if Buf (Pos) = ASCII.LF then + Pos := Pos + 1; + end if; + else + pragma Assert (C = ASCII.LF); + if Buf (Pos) = ASCII.CR then + Pos := Pos + 1; + end if; + end if; + + Line := Line + 1; + end loop; + end Disp_Current_Lines; + + procedure Disp_Source_Line (Loc : Location_Type) + is + use Files_Map; + + File : Source_File_Entry; + Line_Pos : Source_Ptr; + Line : Natural; + Offset : Natural; + Buf : File_Buffer_Acc; + Next_Line_Pos : Source_Ptr; + begin + Location_To_Coord (Loc, File, Line_Pos, Line, Offset); + Buf := Get_File_Source (File); + Next_Line_Pos := File_Line_To_Position (File, Line + 1); + Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); + end Disp_Source_Line; + + -- The status of the debugger. This status can be modified by a command + -- as a side effect to resume or quit the debugger. + type Command_Status_Type is (Status_Default, Status_Quit); + Command_Status : Command_Status_Type; + + -- This exception can be raised by a debugger command to directly return + -- to the prompt. + Command_Error : exception; + + type Menu_Procedure is access procedure (Line : String); + + -- If set (by commands), call this procedure on empty line to repeat + -- last command. + Cmd_Repeat : Menu_Procedure; + + type Menu_Kind is (Menu_Command, Menu_Submenu); + type Menu_Entry (Kind : Menu_Kind); + type Menu_Entry_Acc is access all Menu_Entry; + + type Cst_String_Acc is access constant String; + + type Menu_Entry (Kind : Menu_Kind) is record + Name : Cst_String_Acc; + Next : Menu_Entry_Acc; + + case Kind is + when Menu_Command => + Proc : Menu_Procedure; + when Menu_Submenu => + First, Last : Menu_Entry_Acc := null; + end case; + end record; + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + function Skip_Blanks (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P; + end Skip_Blanks; + + -- Return the position of the last character of the word (the last + -- non-blank character). + function Get_Word (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then not Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P - 1; + end Get_Word; + + procedure Disp_Memtyp (M : Memtyp; Vtype : Node); + + procedure Disp_Discrete_Value (Val : Int64; Btype : Node) is + begin + case Get_Kind (Btype) is + when Iir_Kind_Integer_Type_Definition => + Put_Int64 (Val); + when Iir_Kind_Enumeration_Type_Definition => + declare + Pos : constant Natural := Natural (Val); + Enums : constant Node_Flist := + Get_Enumeration_Literal_List (Btype); + Id : constant Name_Id := + Get_Identifier (Get_Nth_Element (Enums, Pos)); + begin + Put (Name_Table.Image (Id)); + end; + when others => + Vhdl.Errors.Error_Kind ("disp_discrete_value", Btype); + end case; + end Disp_Discrete_Value; + + procedure Disp_Value_Vector (Mem : Memtyp; A_Type: Node; Bound : Bound_Type) + is + El_Type : constant Node := Get_Base_Type (Get_Element_Subtype (A_Type)); + El_Typ : constant Type_Acc := Get_Array_Element (Mem.Typ); + type Last_Enum_Type is (None, Char, Identifier); + Last_Enum : Last_Enum_Type; + Enum_List : Node_Flist; + El_Id : Name_Id; + El_Pos : Natural; + begin + -- Pretty print vectors of enumerated types + if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition then + Last_Enum := None; + Enum_List := Get_Enumeration_Literal_List (El_Type); + for I in 1 .. Bound.Len loop + El_Pos := Natural + (Read_Discrete + (Memtyp'(El_Typ, Mem.Mem + Size_Type (I - 1) * El_Typ.Sz))); + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then + case Last_Enum is + when None => + Put (""""); + when Identifier => + Put (" & """); + when Char => + null; + end case; + Put (Name_Table.Get_Character (El_Id)); + Last_Enum := Char; + else + case Last_Enum is + when None => + null; + when Identifier => + Put (" & "); + when Char => + Put (""" & "); + end case; + Put (Name_Table.Image (El_Id)); + Last_Enum := Identifier; + end if; + end loop; + case Last_Enum is + when None => + Put (""""""); -- Simply "" + when Identifier => + null; + when Char => + Put (""""); + end case; + else + Put ("("); + for I in 1 .. Bound.Len loop + if I /= 1 then + Put (", "); + end if; + Disp_Memtyp ((El_Typ, Mem.Mem + Size_Type (I - 1) * Mem.Typ.Sz), + El_Type); + end loop; + Put (")"); + end if; + end Disp_Value_Vector; + + procedure Disp_Value_Array (Mem : Memtyp; A_Type: Node; Dim: Dim_Type) + is + Stride : Size_Type; + begin + if Dim = Mem.Typ.Abounds.Ndim then + -- Last dimension + Disp_Value_Vector (Mem, A_Type, Mem.Typ.Abounds.D (Dim)); + else + Stride := Mem.Typ.Arr_El.Sz; + for I in Dim + 1 .. Mem.Typ.Abounds.Ndim loop + Stride := Stride * Size_Type (Mem.Typ.Abounds.D (I).Len); + end loop; + + Put ("("); + for I in 1 .. Mem.Typ.Abounds.D (Dim).Len loop + if I /= 1 then + Put (", "); + end if; + Disp_Value_Array ((Mem.Typ, Mem.Mem + Stride), A_Type, Dim + 1); + end loop; + Put (")"); + end if; + end Disp_Value_Array; + + procedure Disp_Memtyp (M : Memtyp; Vtype : Node) is + begin + if M.Mem = null then + Put ("*NULL*"); + return; + end if; + + case M.Typ.Kind is + when Type_Discrete + | Type_Bit + | Type_Logic => + Disp_Discrete_Value (Read_Discrete (M), Get_Base_Type (Vtype)); + when Type_Vector => + Disp_Value_Vector (M, Vtype, M.Typ.Vbound); + when Type_Array => + Disp_Value_Array (M, Vtype, 1); + when Type_Float => + Put ("*float*"); + when Type_Slice => + Put ("*slice*"); + when Type_File => + Put ("*file*"); + when Type_Record => + Put ("*record*"); + when Type_Access => + Put ("*access*"); + when Type_Protected => + Put ("*protected*"); + when Type_Unbounded_Array + | Type_Unbounded_Record + | Type_Unbounded_Vector => + Put ("*unbounded*"); + end case; + end Disp_Memtyp; + + procedure Disp_Value (Vt : Valtyp; Vtype : Node) is + begin + if Vt.Val = null then + Put ("*NULL*"); + return; + end if; + + case Vt.Val.Kind is + when Value_Net => + Put ("net"); + when Value_Wire => + Put ("wire"); + when Value_Signal => + Put ("signal"); + when Value_File => + Put ("file"); + when Value_Const => + Put ("const: "); + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + when Value_Alias => + Put ("alias"); + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + when Value_Memory => + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + end case; + end Disp_Value; + + procedure Disp_Bound_Type (Bound : Bound_Type) is + begin + Put_Int32 (Bound.Left); + Put (' '); + case Bound.Dir is + when Dir_To => + Put ("to"); + when Dir_Downto => + Put ("downto"); + end case; + Put (' '); + Put_Int32 (Bound.Right); + end Disp_Bound_Type; + + procedure Disp_Type (Typ : Type_Acc; Vtype : Node) + is + pragma Unreferenced (Vtype); + begin + case Typ.Kind is + when Type_Bit => + Put ("bit"); + when Type_Logic => + Put ("logic"); + when Type_Discrete => + Put ("discrete"); + when Type_Float => + Put ("float"); + when Type_Vector => + Put ("vector ("); + Disp_Bound_Type (Typ.Vbound); + Put (')'); + when Type_Unbounded_Vector => + Put ("unbounded_vector"); + when Type_Array => + Put ("array"); + when Type_Unbounded_Array => + Put ("unbounded_array"); + when Type_Unbounded_Record => + Put ("unbounded_record"); + when Type_Record => + Put ("record"); + when Type_Slice => + Put ("slice"); + when Type_Access => + Put ("access"); + when Type_File => + Put ("file"); + when Type_Protected => + Put ("protected"); + end case; + end Disp_Type; + + procedure Disp_Declaration_Object + (Instance : Synth_Instance_Acc; Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration => + declare + Val : constant Valtyp := Get_Value (Instance, Decl); + Dtype : constant Node := Get_Type (Decl); + begin + Put (Vhdl.Errors.Disp_Node (Decl)); + Put (": "); + Disp_Type (Val.Typ, Dtype); + Put (" = "); + Disp_Value (Val, Dtype); + New_Line; + end; + when Iir_Kinds_Signal_Attribute => + -- FIXME: todo ? + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when Iir_Kind_Function_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Procedure_Body => + null; + when others => + Vhdl.Errors.Error_Kind ("disp_declaration_object", Decl); + end case; + end Disp_Declaration_Object; + + procedure Disp_Declaration_Objects + (Instance : Synth_Instance_Acc; Decl_Chain : Iir) + is + El : Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + Disp_Declaration_Object (Instance, El); + El := Get_Chain (El); + end loop; + end Disp_Declaration_Objects; + + procedure Info_Params_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Params : Iir; + begin + Decl := Get_Source_Scope (Current_Instance); + loop + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + Decl := Get_Subprogram_Specification (Decl); + exit; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Put_Line ("processes have no parameters"); + return; + when Iir_Kind_While_Loop_Statement + | Iir_Kind_If_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Case_Statement => + Decl := Get_Parent (Decl); + when others => + Vhdl.Errors.Error_Kind ("info_params_proc", Decl); + end case; + end loop; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Current_Instance, Params); + end Info_Params_Proc; + + procedure Info_Locals_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Decls : Iir; + begin + -- From statement to declaration. + Decl := Get_Source_Scope (Current_Instance); + loop + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Generate_Statement_Body => + Decls := Get_Declaration_Chain (Decl); + exit; + when Iir_Kind_While_Loop_Statement + | Iir_Kind_If_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Case_Statement => + Decl := Get_Parent (Decl); + when others => + Vhdl.Errors.Error_Kind ("info_params_proc", Decl); + end case; + end loop; + Disp_Declaration_Objects (Current_Instance, Decls); + end Info_Locals_Proc; + + procedure Info_Instance_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Debug_Synth_Instance (Current_Instance); + end Info_Instance_Proc; + + function Walk_Files (Cb : Walk_Cb) return Walk_Status + is + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + File : Iir_Design_File; + begin + while Lib /= Null_Iir loop + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + case Cb.all (File) is + when Walk_Continue => + null; + when Walk_Up => + exit; + when Walk_Abort => + return Walk_Abort; + end case; + File := Get_Chain (File); + end loop; + Lib := Get_Chain (Lib); + end loop; + return Walk_Continue; + end Walk_Files; + + Walk_Units_Cb : Walk_Cb; + + function Cb_Walk_Units (Design_File : Iir) return Walk_Status + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is + when Walk_Continue => + null; + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + exit; + end case; + Unit := Get_Chain (Unit); + end loop; + return Walk_Continue; + end Cb_Walk_Units; + + function Walk_Units (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Units_Cb := Cb; + return Walk_Files (Cb_Walk_Units'Access); + end Walk_Units; + + Walk_Declarations_Cb : Walk_Cb; + + function Cb_Walk_Declarations (Unit : Iir) return Walk_Status + is + function Walk_Decl_Chain (Chain : Iir) return Walk_Status + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Walk_Declarations_Cb.all (Decl) is + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + return Walk_Continue; + when Walk_Continue => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return Walk_Continue; + end Walk_Decl_Chain; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status; + + function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is + begin + if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then + return Walk_Abort; + end if; + if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort + then + return Walk_Abort; + end if; + return Walk_Continue; + end Walk_Generate_Statement_Body; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status + is + Stmt : Iir := Chain; + begin + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kinds_Process_Statement => + if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) + = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_For_Generate_Statement => + if Walk_Declarations_Cb.all + (Get_Parameter_Specification (Stmt)) = Walk_Abort + or else Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_If_Generate_Statement => + declare + Stmt1 : Iir; + begin + Stmt1 := Stmt; + while Stmt1 /= Null_Iir loop + if Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + Stmt1 := Get_Generate_Else_Clause (Stmt1); + end loop; + end; + when Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Concurrent_Simple_Signal_Assignment => + null; + when Iir_Kind_Block_Statement => + -- FIXME: header + if (Walk_Decl_Chain + (Get_Declaration_Chain (Stmt)) = Walk_Abort) + or else + (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) + then + return Walk_Abort; + end if; + when others => + Vhdl.Errors.Error_Kind ("walk_conc_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + return Walk_Continue; + end Walk_Conc_Chain; + begin + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort + or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort + or else (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Architecture_Body => + if (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_Configuration_Declaration => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + -- FIXME: block configuration ? + when Iir_Kind_Context_Declaration => + null; + when others => + Vhdl.Errors.Error_Kind ("Cb_Walk_Declarations", Unit); + end case; + return Walk_Continue; + end Cb_Walk_Declarations; + + function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Declarations_Cb := Cb; + return Walk_Units (Cb_Walk_Declarations'Access); + end Walk_Declarations; + + -- Next statement in the same frame, but handle compound statements as + -- one statement. + procedure Next_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Current_Instance; + Exec_Statement := Current_Loc; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Next_Stmt_Proc; + + -- Finish parent statement. + procedure Finish_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Current_Instance; + Exec_Statement := Get_Parent (Current_Loc); + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Finish_Stmt_Proc; + + procedure Next_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next; + Exec_Instance := Current_Instance; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Next_Proc'Access; + end Next_Proc; + + procedure Step_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Single_Step; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Step_Proc'Access; + end Step_Proc; + + Break_Id : Name_Id; + + procedure Set_Breakpoint (Stmt : Iir) is + begin + Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); + Breakpoints.Append (Stmt); + Flag_Need_Debug := True; + end Set_Breakpoint; + + function Cb_Set_Break (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Identifier (El) = Break_Id + and then + Get_Implicit_Definition (El) not in Iir_Predefined_Implicit + then + Set_Breakpoint + (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); + end if; + when others => + null; + end case; + return Walk_Continue; + end Cb_Set_Break; + + procedure Break_Proc (Line : String) + is + Status : Walk_Status; + P : Natural; + begin + P := Skip_Blanks (Line); + if Line (P) = '"' then + -- An operator name. + declare + use Str_Table; + Str : String8_Id; + Len : Nat32; + begin + Str := Create_String8; + Len := 0; + P := P + 1; + while Line (P) /= '"' loop + Append_String8_Char (Line (P)); + Len := Len + 1; + P := P + 1; + end loop; + Break_Id := Vhdl.Parse.Str_To_Operator_Name + (Str, Len, No_Location); + -- FIXME: free string. + -- FIXME: catch error. + end; + else + Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); + end if; + Status := Walk_Declarations (Cb_Set_Break'Access); + pragma Assert (Status = Walk_Continue); + end Break_Proc; + + procedure Help_Proc (Line : String); + + procedure Prepare_Continue is + begin + Command_Status := Status_Quit; + + -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. + Flag_Need_Debug := False; + for I in Breakpoints.First .. Breakpoints.Last loop + Flag_Need_Debug := True; + exit; + end loop; + end Prepare_Continue; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Prepare_Continue; + end Cont_Proc; + + procedure List_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Disp_Current_Lines; + end List_Proc; + + Menu_Info_Instance : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("inst*ance"), + Next => null, -- Menu_Info_Tree'Access, + Proc => Info_Instance_Proc'Access); + + Menu_Info_Locals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("locals"), + Next => Menu_Info_Instance'Access, + Proc => Info_Locals_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Locals'Access, -- Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => new String'("i*nfo"), + Next => null, -- Menu_Ps'Access, + First | Last => Menu_Info_Params'Access); -- Menu_Info_Proc'Access); + + Menu_List : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("l*list"), + Next => Menu_Info'Access, -- null, + Proc => List_Proc'Access); + + Menu_Cont : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("c*ont"), + Next => Menu_List'Access, --Menu_Print'Access, + Proc => Cont_Proc'Access); + + Menu_Nstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ns*tmt"), + Next => Menu_Cont'Access, -- Menu_Up'Access, + Proc => Next_Stmt_Proc'Access); + + Menu_Fstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("fs*tmt"), + Next => Menu_Nstmt'Access, + Proc => Finish_Stmt_Proc'Access); + + Menu_Next : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("n*ext"), + Next => Menu_Fstmt'Access, + Proc => Next_Proc'Access); + + Menu_Step : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("s*tep"), + Next => Menu_Next'Access, + Proc => Step_Proc'Access); + + Menu_Break : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("b*reak"), + Next => Menu_Step'Access, + Proc => Break_Proc'Access); + + Menu_Help2 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("?"), + Next => Menu_Break'Access, -- Menu_Help1'Access, + Proc => Help_Proc'Access); + + Menu_Top : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => null, + Next => null, + First | Last => Menu_Help2'Access); + + + function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) + return Menu_Entry_Acc + is + function Is_Cmd (Cmd_Name : String; Str : String) return Boolean + is + -- Number of characters that were compared. + P : Natural; + begin + P := 0; + -- Prefix (before the '*'). + loop + if P = Cmd_Name'Length then + -- Full match. + return P = Str'Length; + end if; + exit when Cmd_Name (Cmd_Name'First + P) = '*'; + if P = Str'Length then + -- Command is too short + return False; + end if; + if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + -- Suffix (after the '*') + loop + if P = Str'Length then + return True; + end if; + if P + 1 = Cmd_Name'Length then + -- String is too long + return False; + end if; + if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + end Is_Cmd; + Ent : Menu_Entry_Acc; + begin + Ent := Menu.First; + while Ent /= null loop + if Is_Cmd (Ent.Name.all, Cmd) then + return Ent; + end if; + Ent := Ent.Next; + end loop; + return null; + end Find_Menu; + + procedure Parse_Command (Line : String; + P : in out Natural; + Menu : out Menu_Entry_Acc) + is + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + return; + end if; + E := Get_Word (Line (P .. Line'Last)); + Menu := Find_Menu (Menu, Line (P .. E)); + if Menu = null then + Put_Line ("command '" & Line (P .. E) & "' not found"); + end if; + P := E + 1; + end Parse_Command; + + procedure Help_Proc (Line : String) + is + P : Natural; + Root : Menu_Entry_Acc := Menu_Top'access; + begin + Put_Line ("This is the help command"); + P := Line'First; + while P < Line'Last loop + Parse_Command (Line, P, Root); + if Root = null then + return; + elsif Root.Kind /= Menu_Submenu then + Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); + return; + end if; + end loop; + + Root := Root.First; + while Root /= null loop + Put (Root.Name.all); + if Root.Kind = Menu_Submenu then + Put (" (menu)"); + end if; + New_Line; + Root := Root.Next; + end loop; + end Help_Proc; + + procedure Debug (Reason: Debug_Reason) + is + use Grt.Readline; + Raw_Line : Char_Ptr; + Prompt : System.Address; + begin + Prompt := Prompt_Debug'Address; + + case Reason is + when Reason_Init => + Prompt := Prompt_Init'Address; + when Reason_Error => + Prompt := Prompt_Error'Address; + when Reason_Break => + case Exec_State is + when Exec_Run => + if not Is_Breakpoint_Hit then + return; + end if; + Put_Line ("breakpoint hit"); + when Exec_Single_Step => + null; + when Exec_Next => + if Current_Instance /= Exec_Instance then + return; + end if; + when Exec_Next_Stmt => + if Current_Instance /= Exec_Instance + or else Is_Within_Statement (Exec_Statement, Current_Loc) + then + return; + end if; + end case; + -- Default state. + Exec_State := Exec_Run; + + end case; + + case Reason is + when Reason_Error + | Reason_Break => + Put ("stopped at: "); + Disp_Iir_Location (Current_Loc); + New_Line; + Disp_Source_Line (Get_Location (Current_Loc)); + when others => + null; + end case; + + if Current_Loc /= Null_Node then + Set_List_Current (Get_Location (Current_Loc)); + end if; + + Command_Status := Status_Default; + + loop + loop + Raw_Line := Readline (Prompt); + -- Skip empty lines + if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then + if Cmd_Repeat /= null then + Cmd_Repeat.all (""); + case Command_Status is + when Status_Default => + null; + when Status_Quit => + return; + end case; + end if; + else + Cmd_Repeat := null; + exit; + end if; + end loop; + declare + Line_Last : constant Natural := Strlen (Raw_Line); + Line : String renames Raw_Line (1 .. Line_Last); + P, E : Positive; + Cmd : Menu_Entry_Acc := Menu_Top'Access; + begin + -- Find command + P := 1; + loop + E := P; + Parse_Command (Line, E, Cmd); + exit when Cmd = null; + case Cmd.Kind is + when Menu_Submenu => + if E > Line_Last then + Put_Line ("missing command for submenu " + & Line (P .. E - 1)); + Cmd := null; + exit; + end if; + P := E; + when Menu_Command => + exit; + end case; + end loop; + + if Cmd /= null then + Cmd.Proc.all (Line (E .. Line_Last)); + + case Command_Status is + when Status_Default => + null; + when Status_Quit => + exit; + end case; + end if; + exception + when Command_Error => + null; + end; + end loop; + -- Put ("resuming"); + end Debug; + + procedure Debug_Init (Top : Node) is + begin + Flag_Enabled := True; + + Current_Instance := null; + Current_Loc := Top; + + -- To avoid warnings. + Exec_Statement := Null_Node; + Exec_Instance := null; + + Debug (Reason_Init); + end Debug_Init; + + procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is + begin + Current_Instance := Inst; + Current_Loc := Stmt; + + Debug (Reason_Break); + end Debug_Break; + + procedure Debug_Leave (Inst : Synth_Instance_Acc) is + begin + if Exec_Instance = Inst then + -- Will be destroyed. + Exec_Instance := null; + + case Exec_State is + when Exec_Run => + null; + when Exec_Single_Step => + null; + when Exec_Next + | Exec_Next_Stmt => + -- Leave the frame, will stop just after. + Exec_State := Exec_Single_Step; + end case; + end if; + end Debug_Leave; + + procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is + begin + if Flag_Enabled then + Current_Instance := Inst; + Current_Loc := Expr; + Debug (Reason_Error); + end if; + end Debug_Error; +end Elab.Debugger; |