1-- Debugging during synthesis. 2-- Copyright (C) 2019 Tristan Gingold 3-- 4-- This file is part of GHDL. 5-- 6-- This program is free software; you can redistribute it and/or modify 7-- it under the terms of the GNU General Public License as published by 8-- the Free Software Foundation; either version 2 of the License, or 9-- (at your option) any later version. 10-- 11-- This program is distributed in the hope that it will be useful, 12-- but WITHOUT ANY WARRANTY; without even the implied warranty of 13-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14-- GNU General Public License for more details. 15-- 16-- You should have received a copy of the GNU General Public License 17-- along with this program; if not, write to the Free Software 18-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, 19-- MA 02110-1301, USA. 20 21with System; 22 23with Types; use Types; 24with Files_Map; 25with Tables; 26with Simple_IO; use Simple_IO; 27with Utils_IO; use Utils_IO; 28with Name_Table; 29with Str_Table; 30with Libraries; 31 32with Grt.Readline; 33 34with Vhdl.Errors; 35with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk; 36with Vhdl.Parse; 37with Vhdl.Utils; use Vhdl.Utils; 38 39with Synth. Objtypes; use Synth.Objtypes; 40with Synth.Values; use Synth.Values; 41-- with Synth.Environment; use Synth.Environment; 42with Synth.Flags; 43 44package body Synth.Debugger is 45 Current_Instance : Synth_Instance_Acc; 46 Current_Loc : Node; 47 48 type Debug_Reason is 49 ( 50 Reason_Init, 51 Reason_Break, 52 Reason_Error 53 ); 54 55 package Breakpoints is new Tables 56 (Table_Index_Type => Natural, 57 Table_Component_Type => Node, 58 Table_Low_Bound => 1, 59 Table_Initial => 16); 60 61 function Is_Breakpoint_Hit return Boolean is 62 begin 63 for I in Breakpoints.First .. Breakpoints.Last loop 64 if Breakpoints.Table (I) = Current_Loc then 65 return True; 66 end if; 67 end loop; 68 return False; 69 end Is_Breakpoint_Hit; 70 71 -- Current execution state, or reason to stop execution (set by the 72 -- last debugger command). 73 type Exec_State_Type is 74 (-- Execution should continue until a breakpoint is reached or assertion 75 -- failure. 76 Exec_Run, 77 78 -- Execution will stop at the next statement. 79 Exec_Single_Step, 80 81 -- Execution will stop at the next simple statement in the same frame. 82 Exec_Next, 83 84 -- Execution will stop at the next statement in the same frame. In 85 -- case of compound statement, stop after the compound statement. 86 Exec_Next_Stmt); 87 88 Exec_State : Exec_State_Type := Exec_Run; 89 90 -- Current frame for next. 91 Exec_Instance : Synth_Instance_Acc; 92 93 -- Current statement for next_stmt. 94 Exec_Statement : Node; 95 96 function Is_Within_Statement (Stmt : Node; Cur : Node) return Boolean 97 is 98 Parent : Node; 99 begin 100 Parent := Cur; 101 loop 102 if Parent = Stmt then 103 return True; 104 end if; 105 case Get_Kind (Parent) is 106 when Iir_Kinds_Sequential_Statement => 107 Parent := Get_Parent (Parent); 108 when others => 109 return False; 110 end case; 111 end loop; 112 end Is_Within_Statement; 113 114 Prompt_Debug : constant String := "debug> " & ASCII.NUL; 115 Prompt_Error : constant String := "error> " & ASCII.NUL; 116 Prompt_Init : constant String := "init> " & ASCII.NUL; 117 -- Prompt_Elab : constant String := "elab> " & ASCII.NUL; 118 119 procedure Disp_Iir_Location (N : Node) is 120 begin 121 if N = Null_Iir then 122 Put_Err ("??:??:??"); 123 else 124 Put_Err (Vhdl.Errors.Disp_Location (N)); 125 end if; 126 Put_Err (": "); 127 end Disp_Iir_Location; 128 129 -- For the list command: current file and current line. 130 List_Current_File : Source_File_Entry := No_Source_File_Entry; 131 List_Current_Line : Natural := 0; 132 List_Current_Line_Pos : Source_Ptr := 0; 133 134 -- Set List_Current_* from a location. To be called after program break 135 -- to indicate current location. 136 procedure Set_List_Current (Loc : Location_Type) 137 is 138 Offset : Natural; 139 begin 140 Files_Map.Location_To_Coord 141 (Loc, List_Current_File, List_Current_Line_Pos, 142 List_Current_Line, Offset); 143 end Set_List_Current; 144 145 procedure Disp_Current_Lines 146 is 147 use Files_Map; 148 -- Number of lines to display before and after the current line. 149 Radius : constant := 5; 150 151 Buf : File_Buffer_Acc; 152 153 Pos : Source_Ptr; 154 Line : Natural; 155 Len : Source_Ptr; 156 C : Character; 157 begin 158 if List_Current_Line > Radius then 159 Line := List_Current_Line - Radius; 160 else 161 Line := 1; 162 end if; 163 164 Pos := File_Line_To_Position (List_Current_File, Line); 165 Buf := Get_File_Source (List_Current_File); 166 167 while Line < List_Current_Line + Radius loop 168 -- Compute line length. 169 Len := 0; 170 loop 171 C := Buf (Pos + Len); 172 exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; 173 Len := Len + 1; 174 end loop; 175 176 -- Disp line number. 177 declare 178 Str : constant String := Natural'Image (Line); 179 begin 180 if Line = List_Current_Line then 181 Put ('*'); 182 else 183 Put (' '); 184 end if; 185 Put ((Str'Length .. 5 => ' ')); 186 Put (Str (Str'First + 1 .. Str'Last)); 187 Put (' '); 188 end; 189 190 -- Disp line. 191 Put_Line (String (Buf (Pos .. Pos + Len - 1))); 192 193 -- Skip EOL. 194 exit when C = ASCII.EOT; 195 Pos := Pos + Len + 1; 196 if C = ASCII.CR then 197 if Buf (Pos) = ASCII.LF then 198 Pos := Pos + 1; 199 end if; 200 else 201 pragma Assert (C = ASCII.LF); 202 if Buf (Pos) = ASCII.CR then 203 Pos := Pos + 1; 204 end if; 205 end if; 206 207 Line := Line + 1; 208 end loop; 209 end Disp_Current_Lines; 210 211 procedure Disp_Source_Line (Loc : Location_Type) 212 is 213 use Files_Map; 214 215 File : Source_File_Entry; 216 Line_Pos : Source_Ptr; 217 Line : Natural; 218 Offset : Natural; 219 Buf : File_Buffer_Acc; 220 Next_Line_Pos : Source_Ptr; 221 begin 222 Location_To_Coord (Loc, File, Line_Pos, Line, Offset); 223 Buf := Get_File_Source (File); 224 Next_Line_Pos := File_Line_To_Position (File, Line + 1); 225 Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); 226 end Disp_Source_Line; 227 228 -- The status of the debugger. This status can be modified by a command 229 -- as a side effect to resume or quit the debugger. 230 type Command_Status_Type is (Status_Default, Status_Quit); 231 Command_Status : Command_Status_Type; 232 233 -- This exception can be raised by a debugger command to directly return 234 -- to the prompt. 235 Command_Error : exception; 236 237 type Menu_Procedure is access procedure (Line : String); 238 239 -- If set (by commands), call this procedure on empty line to repeat 240 -- last command. 241 Cmd_Repeat : Menu_Procedure; 242 243 type Menu_Kind is (Menu_Command, Menu_Submenu); 244 type Menu_Entry (Kind : Menu_Kind); 245 type Menu_Entry_Acc is access all Menu_Entry; 246 247 type Cst_String_Acc is access constant String; 248 249 type Menu_Entry (Kind : Menu_Kind) is record 250 Name : Cst_String_Acc; 251 Next : Menu_Entry_Acc; 252 253 case Kind is 254 when Menu_Command => 255 Proc : Menu_Procedure; 256 when Menu_Submenu => 257 First, Last : Menu_Entry_Acc := null; 258 end case; 259 end record; 260 261 function Is_Blank (C : Character) return Boolean is 262 begin 263 return C = ' ' or else C = ASCII.HT; 264 end Is_Blank; 265 266 function Skip_Blanks (S : String) return Positive 267 is 268 P : Positive := S'First; 269 begin 270 while P <= S'Last and then Is_Blank (S (P)) loop 271 P := P + 1; 272 end loop; 273 return P; 274 end Skip_Blanks; 275 276 -- Return the position of the last character of the word (the last 277 -- non-blank character). 278 function Get_Word (S : String) return Positive 279 is 280 P : Positive := S'First; 281 begin 282 while P <= S'Last and then not Is_Blank (S (P)) loop 283 P := P + 1; 284 end loop; 285 return P - 1; 286 end Get_Word; 287 288 procedure Disp_Memtyp (M : Memtyp; Vtype : Node); 289 290 procedure Disp_Discrete_Value (Val : Int64; Btype : Node) is 291 begin 292 case Get_Kind (Btype) is 293 when Iir_Kind_Integer_Type_Definition => 294 Put_Int64 (Val); 295 when Iir_Kind_Enumeration_Type_Definition => 296 declare 297 Pos : constant Natural := Natural (Val); 298 Enums : constant Node_Flist := 299 Get_Enumeration_Literal_List (Btype); 300 Id : constant Name_Id := 301 Get_Identifier (Get_Nth_Element (Enums, Pos)); 302 begin 303 Put (Name_Table.Image (Id)); 304 end; 305 when others => 306 Vhdl.Errors.Error_Kind ("disp_discrete_value", Btype); 307 end case; 308 end Disp_Discrete_Value; 309 310 procedure Disp_Value_Vector (Mem : Memtyp; A_Type: Node; Bound : Bound_Type) 311 is 312 El_Type : constant Node := Get_Base_Type (Get_Element_Subtype (A_Type)); 313 El_Typ : constant Type_Acc := Get_Array_Element (Mem.Typ); 314 type Last_Enum_Type is (None, Char, Identifier); 315 Last_Enum : Last_Enum_Type; 316 Enum_List : Node_Flist; 317 El_Id : Name_Id; 318 El_Pos : Natural; 319 begin 320 -- Pretty print vectors of enumerated types 321 if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition then 322 Last_Enum := None; 323 Enum_List := Get_Enumeration_Literal_List (El_Type); 324 for I in 1 .. Bound.Len loop 325 El_Pos := Natural 326 (Read_Discrete 327 (Memtyp'(El_Typ, Mem.Mem + Size_Type (I - 1) * El_Typ.Sz))); 328 El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); 329 if Name_Table.Is_Character (El_Id) then 330 case Last_Enum is 331 when None => 332 Put (""""); 333 when Identifier => 334 Put (" & """); 335 when Char => 336 null; 337 end case; 338 Put (Name_Table.Get_Character (El_Id)); 339 Last_Enum := Char; 340 else 341 case Last_Enum is 342 when None => 343 null; 344 when Identifier => 345 Put (" & "); 346 when Char => 347 Put (""" & "); 348 end case; 349 Put (Name_Table.Image (El_Id)); 350 Last_Enum := Identifier; 351 end if; 352 end loop; 353 case Last_Enum is 354 when None => 355 Put (""""""); -- Simply "" 356 when Identifier => 357 null; 358 when Char => 359 Put (""""); 360 end case; 361 else 362 Put ("("); 363 for I in 1 .. Bound.Len loop 364 if I /= 1 then 365 Put (", "); 366 end if; 367 Disp_Memtyp ((El_Typ, Mem.Mem + Size_Type (I - 1) * Mem.Typ.Sz), 368 El_Type); 369 end loop; 370 Put (")"); 371 end if; 372 end Disp_Value_Vector; 373 374 procedure Disp_Value_Array (Mem : Memtyp; A_Type: Node; Dim: Dim_Type) 375 is 376 Stride : Size_Type; 377 begin 378 if Dim = Mem.Typ.Abounds.Ndim then 379 -- Last dimension 380 Disp_Value_Vector (Mem, A_Type, Mem.Typ.Abounds.D (Dim)); 381 else 382 Stride := Mem.Typ.Arr_El.Sz; 383 for I in Dim + 1 .. Mem.Typ.Abounds.Ndim loop 384 Stride := Stride * Size_Type (Mem.Typ.Abounds.D (I).Len); 385 end loop; 386 387 Put ("("); 388 for I in 1 .. Mem.Typ.Abounds.D (Dim).Len loop 389 if I /= 1 then 390 Put (", "); 391 end if; 392 Disp_Value_Array ((Mem.Typ, Mem.Mem + Stride), A_Type, Dim + 1); 393 end loop; 394 Put (")"); 395 end if; 396 end Disp_Value_Array; 397 398 procedure Disp_Memtyp (M : Memtyp; Vtype : Node) is 399 begin 400 if M.Mem = null then 401 Put ("*NULL*"); 402 return; 403 end if; 404 405 case M.Typ.Kind is 406 when Type_Discrete 407 | Type_Bit 408 | Type_Logic => 409 Disp_Discrete_Value (Read_Discrete (M), Get_Base_Type (Vtype)); 410 when Type_Vector => 411 Disp_Value_Vector (M, Vtype, M.Typ.Vbound); 412 when Type_Array => 413 Disp_Value_Array (M, Vtype, 1); 414 when Type_Float => 415 Put ("*float*"); 416 when Type_Slice => 417 Put ("*slice*"); 418 when Type_File => 419 Put ("*file*"); 420 when Type_Record => 421 Put ("*record*"); 422 when Type_Access => 423 Put ("*access*"); 424 when Type_Protected => 425 Put ("*protected*"); 426 when Type_Unbounded_Array 427 | Type_Unbounded_Record 428 | Type_Unbounded_Vector => 429 Put ("*unbounded*"); 430 end case; 431 end Disp_Memtyp; 432 433 procedure Disp_Value (Vt : Valtyp; Vtype : Node) is 434 begin 435 if Vt.Val = null then 436 Put ("*NULL*"); 437 return; 438 end if; 439 440 case Vt.Val.Kind is 441 when Value_Net => 442 Put ("net"); 443 when Value_Wire => 444 Put ("wire"); 445 when Value_File => 446 Put ("file"); 447 when Value_Const => 448 Put ("const: "); 449 Disp_Memtyp (Get_Memtyp (Vt), Vtype); 450 when Value_Alias => 451 Put ("alias"); 452 Disp_Memtyp (Get_Memtyp (Vt), Vtype); 453 when Value_Memory => 454 Disp_Memtyp (Get_Memtyp (Vt), Vtype); 455 end case; 456 end Disp_Value; 457 458 procedure Disp_Bound_Type (Bound : Bound_Type) is 459 begin 460 Put_Int32 (Bound.Left); 461 Put (' '); 462 case Bound.Dir is 463 when Dir_To => 464 Put ("to"); 465 when Dir_Downto => 466 Put ("downto"); 467 end case; 468 Put (' '); 469 Put_Int32 (Bound.Right); 470 end Disp_Bound_Type; 471 472 procedure Disp_Type (Typ : Type_Acc; Vtype : Node) 473 is 474 pragma Unreferenced (Vtype); 475 begin 476 case Typ.Kind is 477 when Type_Bit => 478 Put ("bit"); 479 when Type_Logic => 480 Put ("logic"); 481 when Type_Discrete => 482 Put ("discrete"); 483 when Type_Float => 484 Put ("float"); 485 when Type_Vector => 486 Put ("vector ("); 487 Disp_Bound_Type (Typ.Vbound); 488 Put (')'); 489 when Type_Unbounded_Vector => 490 Put ("unbounded_vector"); 491 when Type_Array => 492 Put ("array"); 493 when Type_Unbounded_Array => 494 Put ("unbounded_array"); 495 when Type_Unbounded_Record => 496 Put ("unbounded_record"); 497 when Type_Record => 498 Put ("record"); 499 when Type_Slice => 500 Put ("slice"); 501 when Type_Access => 502 Put ("access"); 503 when Type_File => 504 Put ("file"); 505 when Type_Protected => 506 Put ("protected"); 507 end case; 508 end Disp_Type; 509 510 procedure Disp_Declaration_Object 511 (Instance : Synth_Instance_Acc; Decl : Iir) is 512 begin 513 case Get_Kind (Decl) is 514 when Iir_Kind_Constant_Declaration 515 | Iir_Kind_Variable_Declaration 516 | Iir_Kind_Interface_Variable_Declaration 517 | Iir_Kind_Interface_Constant_Declaration 518 | Iir_Kind_Interface_File_Declaration 519 | Iir_Kind_Object_Alias_Declaration 520 | Iir_Kind_Interface_Signal_Declaration 521 | Iir_Kind_Signal_Declaration 522 | Iir_Kind_File_Declaration => 523 declare 524 Val : constant Valtyp := Get_Value (Instance, Decl); 525 Dtype : constant Node := Get_Type (Decl); 526 begin 527 Put (Vhdl.Errors.Disp_Node (Decl)); 528 Put (": "); 529 Disp_Type (Val.Typ, Dtype); 530 Put (" = "); 531 Disp_Value (Val, Dtype); 532 New_Line; 533 end; 534 when Iir_Kinds_Signal_Attribute => 535 -- FIXME: todo ? 536 null; 537 when Iir_Kind_Type_Declaration 538 | Iir_Kind_Anonymous_Type_Declaration 539 | Iir_Kind_Subtype_Declaration => 540 -- FIXME: disp ranges 541 null; 542 when Iir_Kind_Function_Declaration 543 | Iir_Kind_Function_Body 544 | Iir_Kind_Procedure_Declaration 545 | Iir_Kind_Procedure_Body => 546 null; 547 when others => 548 Vhdl.Errors.Error_Kind ("disp_declaration_object", Decl); 549 end case; 550 end Disp_Declaration_Object; 551 552 procedure Disp_Declaration_Objects 553 (Instance : Synth_Instance_Acc; Decl_Chain : Iir) 554 is 555 El : Iir; 556 begin 557 El := Decl_Chain; 558 while El /= Null_Iir loop 559 Disp_Declaration_Object (Instance, El); 560 El := Get_Chain (El); 561 end loop; 562 end Disp_Declaration_Objects; 563 564 procedure Info_Params_Proc (Line : String) 565 is 566 pragma Unreferenced (Line); 567 Decl : Iir; 568 Params : Iir; 569 begin 570 Decl := Get_Source_Scope (Current_Instance); 571 loop 572 case Get_Kind (Decl) is 573 when Iir_Kind_Procedure_Body 574 | Iir_Kind_Function_Body => 575 Decl := Get_Subprogram_Specification (Decl); 576 exit; 577 when Iir_Kind_Process_Statement 578 | Iir_Kind_Sensitized_Process_Statement => 579 Put_Line ("processes have no parameters"); 580 return; 581 when Iir_Kind_While_Loop_Statement 582 | Iir_Kind_If_Statement 583 | Iir_Kind_For_Loop_Statement 584 | Iir_Kind_Case_Statement => 585 Decl := Get_Parent (Decl); 586 when others => 587 Vhdl.Errors.Error_Kind ("info_params_proc", Decl); 588 end case; 589 end loop; 590 Params := Get_Interface_Declaration_Chain (Decl); 591 Disp_Declaration_Objects (Current_Instance, Params); 592 end Info_Params_Proc; 593 594 procedure Info_Locals_Proc (Line : String) 595 is 596 pragma Unreferenced (Line); 597 Decl : Iir; 598 Decls : Iir; 599 begin 600 -- From statement to declaration. 601 Decl := Get_Source_Scope (Current_Instance); 602 loop 603 case Get_Kind (Decl) is 604 when Iir_Kind_Procedure_Body 605 | Iir_Kind_Function_Body => 606 Decls := Get_Declaration_Chain (Decl); 607 exit; 608 when Iir_Kind_Process_Statement 609 | Iir_Kind_Sensitized_Process_Statement => 610 Put_Line ("processes have no parameters"); 611 return; 612 when Iir_Kind_While_Loop_Statement 613 | Iir_Kind_If_Statement 614 | Iir_Kind_For_Loop_Statement 615 | Iir_Kind_Case_Statement => 616 Decl := Get_Parent (Decl); 617 when others => 618 Vhdl.Errors.Error_Kind ("info_params_proc", Decl); 619 end case; 620 end loop; 621 Disp_Declaration_Objects (Current_Instance, Decls); 622 end Info_Locals_Proc; 623 624 function Walk_Files (Cb : Walk_Cb) return Walk_Status 625 is 626 Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; 627 File : Iir_Design_File; 628 begin 629 while Lib /= Null_Iir loop 630 File := Get_Design_File_Chain (Lib); 631 while File /= Null_Iir loop 632 case Cb.all (File) is 633 when Walk_Continue => 634 null; 635 when Walk_Up => 636 exit; 637 when Walk_Abort => 638 return Walk_Abort; 639 end case; 640 File := Get_Chain (File); 641 end loop; 642 Lib := Get_Chain (Lib); 643 end loop; 644 return Walk_Continue; 645 end Walk_Files; 646 647 Walk_Units_Cb : Walk_Cb; 648 649 function Cb_Walk_Units (Design_File : Iir) return Walk_Status 650 is 651 Unit : Iir_Design_Unit; 652 begin 653 Unit := Get_First_Design_Unit (Design_File); 654 while Unit /= Null_Iir loop 655 case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is 656 when Walk_Continue => 657 null; 658 when Walk_Abort => 659 return Walk_Abort; 660 when Walk_Up => 661 exit; 662 end case; 663 Unit := Get_Chain (Unit); 664 end loop; 665 return Walk_Continue; 666 end Cb_Walk_Units; 667 668 function Walk_Units (Cb : Walk_Cb) return Walk_Status is 669 begin 670 Walk_Units_Cb := Cb; 671 return Walk_Files (Cb_Walk_Units'Access); 672 end Walk_Units; 673 674 Walk_Declarations_Cb : Walk_Cb; 675 676 function Cb_Walk_Declarations (Unit : Iir) return Walk_Status 677 is 678 function Walk_Decl_Chain (Chain : Iir) return Walk_Status 679 is 680 Decl : Iir; 681 begin 682 Decl := Chain; 683 while Decl /= Null_Iir loop 684 case Walk_Declarations_Cb.all (Decl) is 685 when Walk_Abort => 686 return Walk_Abort; 687 when Walk_Up => 688 return Walk_Continue; 689 when Walk_Continue => 690 null; 691 end case; 692 Decl := Get_Chain (Decl); 693 end loop; 694 return Walk_Continue; 695 end Walk_Decl_Chain; 696 697 function Walk_Conc_Chain (Chain : Iir) return Walk_Status; 698 699 function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is 700 begin 701 if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then 702 return Walk_Abort; 703 end if; 704 if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort 705 then 706 return Walk_Abort; 707 end if; 708 return Walk_Continue; 709 end Walk_Generate_Statement_Body; 710 711 function Walk_Conc_Chain (Chain : Iir) return Walk_Status 712 is 713 Stmt : Iir := Chain; 714 begin 715 while Stmt /= Null_Iir loop 716 case Get_Kind (Stmt) is 717 when Iir_Kinds_Process_Statement => 718 if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) 719 = Walk_Abort 720 then 721 return Walk_Abort; 722 end if; 723 when Iir_Kind_For_Generate_Statement => 724 if Walk_Declarations_Cb.all 725 (Get_Parameter_Specification (Stmt)) = Walk_Abort 726 or else Walk_Generate_Statement_Body 727 (Get_Generate_Statement_Body (Stmt)) = Walk_Abort 728 then 729 return Walk_Abort; 730 end if; 731 when Iir_Kind_If_Generate_Statement => 732 declare 733 Stmt1 : Iir; 734 begin 735 Stmt1 := Stmt; 736 while Stmt1 /= Null_Iir loop 737 if Walk_Generate_Statement_Body 738 (Get_Generate_Statement_Body (Stmt)) = Walk_Abort 739 then 740 return Walk_Abort; 741 end if; 742 Stmt1 := Get_Generate_Else_Clause (Stmt1); 743 end loop; 744 end; 745 when Iir_Kind_Component_Instantiation_Statement 746 | Iir_Kind_Concurrent_Simple_Signal_Assignment => 747 null; 748 when Iir_Kind_Block_Statement => 749 -- FIXME: header 750 if (Walk_Decl_Chain 751 (Get_Declaration_Chain (Stmt)) = Walk_Abort) 752 or else 753 (Walk_Conc_Chain 754 (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) 755 then 756 return Walk_Abort; 757 end if; 758 when others => 759 Vhdl.Errors.Error_Kind ("walk_conc_chain", Stmt); 760 end case; 761 Stmt := Get_Chain (Stmt); 762 end loop; 763 return Walk_Continue; 764 end Walk_Conc_Chain; 765 begin 766 case Get_Kind (Unit) is 767 when Iir_Kind_Entity_Declaration => 768 if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort 769 or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort 770 or else (Walk_Decl_Chain 771 (Get_Declaration_Chain (Unit)) = Walk_Abort) 772 or else (Walk_Conc_Chain 773 (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) 774 then 775 return Walk_Abort; 776 end if; 777 when Iir_Kind_Architecture_Body => 778 if (Walk_Decl_Chain 779 (Get_Declaration_Chain (Unit)) = Walk_Abort) 780 or else (Walk_Conc_Chain 781 (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) 782 then 783 return Walk_Abort; 784 end if; 785 when Iir_Kind_Package_Declaration 786 | Iir_Kind_Package_Body => 787 if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort 788 then 789 return Walk_Abort; 790 end if; 791 when Iir_Kind_Configuration_Declaration => 792 if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort 793 then 794 return Walk_Abort; 795 end if; 796 -- FIXME: block configuration ? 797 when Iir_Kind_Context_Declaration => 798 null; 799 when others => 800 Vhdl.Errors.Error_Kind ("Cb_Walk_Declarations", Unit); 801 end case; 802 return Walk_Continue; 803 end Cb_Walk_Declarations; 804 805 function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is 806 begin 807 Walk_Declarations_Cb := Cb; 808 return Walk_Units (Cb_Walk_Declarations'Access); 809 end Walk_Declarations; 810 811 -- Next statement in the same frame, but handle compound statements as 812 -- one statement. 813 procedure Next_Stmt_Proc (Line : String) 814 is 815 pragma Unreferenced (Line); 816 begin 817 Exec_State := Exec_Next_Stmt; 818 Exec_Instance := Current_Instance; 819 Exec_Statement := Current_Loc; 820 Flag_Need_Debug := True; 821 Command_Status := Status_Quit; 822 end Next_Stmt_Proc; 823 824 -- Finish parent statement. 825 procedure Finish_Stmt_Proc (Line : String) 826 is 827 pragma Unreferenced (Line); 828 begin 829 Exec_State := Exec_Next_Stmt; 830 Exec_Instance := Current_Instance; 831 Exec_Statement := Get_Parent (Current_Loc); 832 Flag_Need_Debug := True; 833 Command_Status := Status_Quit; 834 end Finish_Stmt_Proc; 835 836 procedure Next_Proc (Line : String) 837 is 838 pragma Unreferenced (Line); 839 begin 840 Exec_State := Exec_Next; 841 Exec_Instance := Current_Instance; 842 Flag_Need_Debug := True; 843 Command_Status := Status_Quit; 844 Cmd_Repeat := Next_Proc'Access; 845 end Next_Proc; 846 847 procedure Step_Proc (Line : String) 848 is 849 pragma Unreferenced (Line); 850 begin 851 Exec_State := Exec_Single_Step; 852 Flag_Need_Debug := True; 853 Command_Status := Status_Quit; 854 Cmd_Repeat := Step_Proc'Access; 855 end Step_Proc; 856 857 Break_Id : Name_Id; 858 859 procedure Set_Breakpoint (Stmt : Iir) is 860 begin 861 Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); 862 Breakpoints.Append (Stmt); 863 Flag_Need_Debug := True; 864 end Set_Breakpoint; 865 866 function Cb_Set_Break (El : Iir) return Walk_Status is 867 begin 868 case Get_Kind (El) is 869 when Iir_Kind_Function_Declaration 870 | Iir_Kind_Procedure_Declaration => 871 if Get_Identifier (El) = Break_Id 872 and then 873 Get_Implicit_Definition (El) not in Iir_Predefined_Implicit 874 then 875 Set_Breakpoint 876 (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); 877 end if; 878 when others => 879 null; 880 end case; 881 return Walk_Continue; 882 end Cb_Set_Break; 883 884 procedure Break_Proc (Line : String) 885 is 886 Status : Walk_Status; 887 P : Natural; 888 begin 889 P := Skip_Blanks (Line); 890 if Line (P) = '"' then 891 -- An operator name. 892 declare 893 use Str_Table; 894 Str : String8_Id; 895 Len : Nat32; 896 begin 897 Str := Create_String8; 898 Len := 0; 899 P := P + 1; 900 while Line (P) /= '"' loop 901 Append_String8_Char (Line (P)); 902 Len := Len + 1; 903 P := P + 1; 904 end loop; 905 Break_Id := Vhdl.Parse.Str_To_Operator_Name 906 (Str, Len, No_Location); 907 -- FIXME: free string. 908 -- FIXME: catch error. 909 end; 910 else 911 Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); 912 end if; 913 Status := Walk_Declarations (Cb_Set_Break'Access); 914 pragma Assert (Status = Walk_Continue); 915 end Break_Proc; 916 917 procedure Help_Proc (Line : String); 918 919 procedure Prepare_Continue is 920 begin 921 Command_Status := Status_Quit; 922 923 -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. 924 Flag_Need_Debug := False; 925 for I in Breakpoints.First .. Breakpoints.Last loop 926 Flag_Need_Debug := True; 927 exit; 928 end loop; 929 end Prepare_Continue; 930 931 procedure Cont_Proc (Line : String) is 932 pragma Unreferenced (Line); 933 begin 934 Prepare_Continue; 935 end Cont_Proc; 936 937 procedure List_Proc (Line : String) 938 is 939 pragma Unreferenced (Line); 940 begin 941 Disp_Current_Lines; 942 end List_Proc; 943 944 Menu_Info_Locals : aliased Menu_Entry := 945 (Kind => Menu_Command, 946 Name => new String'("locals"), 947 Next => null, -- Menu_Info_Tree'Access, 948 Proc => Info_Locals_Proc'Access); 949 950 Menu_Info_Params : aliased Menu_Entry := 951 (Kind => Menu_Command, 952 Name => new String'("param*eters"), 953 Next => Menu_Info_Locals'Access, -- Menu_Info_Tree'Access, 954 Proc => Info_Params_Proc'Access); 955 956 Menu_Info : aliased Menu_Entry := 957 (Kind => Menu_Submenu, 958 Name => new String'("i*nfo"), 959 Next => null, -- Menu_Ps'Access, 960 First | Last => Menu_Info_Params'Access); -- Menu_Info_Proc'Access); 961 962 Menu_List : aliased Menu_Entry := 963 (Kind => Menu_Command, 964 Name => new String'("l*list"), 965 Next => Menu_Info'Access, -- null, 966 Proc => List_Proc'Access); 967 968 Menu_Cont : aliased Menu_Entry := 969 (Kind => Menu_Command, 970 Name => new String'("c*ont"), 971 Next => Menu_List'Access, --Menu_Print'Access, 972 Proc => Cont_Proc'Access); 973 974 Menu_Nstmt : aliased Menu_Entry := 975 (Kind => Menu_Command, 976 Name => new String'("ns*tmt"), 977 Next => Menu_Cont'Access, -- Menu_Up'Access, 978 Proc => Next_Stmt_Proc'Access); 979 980 Menu_Fstmt : aliased Menu_Entry := 981 (Kind => Menu_Command, 982 Name => new String'("fs*tmt"), 983 Next => Menu_Nstmt'Access, 984 Proc => Finish_Stmt_Proc'Access); 985 986 Menu_Next : aliased Menu_Entry := 987 (Kind => Menu_Command, 988 Name => new String'("n*ext"), 989 Next => Menu_Fstmt'Access, 990 Proc => Next_Proc'Access); 991 992 Menu_Step : aliased Menu_Entry := 993 (Kind => Menu_Command, 994 Name => new String'("s*tep"), 995 Next => Menu_Next'Access, 996 Proc => Step_Proc'Access); 997 998 Menu_Break : aliased Menu_Entry := 999 (Kind => Menu_Command, 1000 Name => new String'("b*reak"), 1001 Next => Menu_Step'Access, 1002 Proc => Break_Proc'Access); 1003 1004 Menu_Help2 : aliased Menu_Entry := 1005 (Kind => Menu_Command, 1006 Name => new String'("?"), 1007 Next => Menu_Break'Access, -- Menu_Help1'Access, 1008 Proc => Help_Proc'Access); 1009 1010 Menu_Top : aliased Menu_Entry := 1011 (Kind => Menu_Submenu, 1012 Name => null, 1013 Next => null, 1014 First | Last => Menu_Help2'Access); 1015 1016 1017 function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) 1018 return Menu_Entry_Acc 1019 is 1020 function Is_Cmd (Cmd_Name : String; Str : String) return Boolean 1021 is 1022 -- Number of characters that were compared. 1023 P : Natural; 1024 begin 1025 P := 0; 1026 -- Prefix (before the '*'). 1027 loop 1028 if P = Cmd_Name'Length then 1029 -- Full match. 1030 return P = Str'Length; 1031 end if; 1032 exit when Cmd_Name (Cmd_Name'First + P) = '*'; 1033 if P = Str'Length then 1034 -- Command is too short 1035 return False; 1036 end if; 1037 if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then 1038 return False; 1039 end if; 1040 P := P + 1; 1041 end loop; 1042 -- Suffix (after the '*') 1043 loop 1044 if P = Str'Length then 1045 return True; 1046 end if; 1047 if P + 1 = Cmd_Name'Length then 1048 -- String is too long 1049 return False; 1050 end if; 1051 if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then 1052 return False; 1053 end if; 1054 P := P + 1; 1055 end loop; 1056 end Is_Cmd; 1057 Ent : Menu_Entry_Acc; 1058 begin 1059 Ent := Menu.First; 1060 while Ent /= null loop 1061 if Is_Cmd (Ent.Name.all, Cmd) then 1062 return Ent; 1063 end if; 1064 Ent := Ent.Next; 1065 end loop; 1066 return null; 1067 end Find_Menu; 1068 1069 procedure Parse_Command (Line : String; 1070 P : in out Natural; 1071 Menu : out Menu_Entry_Acc) 1072 is 1073 E : Natural; 1074 begin 1075 P := Skip_Blanks (Line (P .. Line'Last)); 1076 if P > Line'Last then 1077 return; 1078 end if; 1079 E := Get_Word (Line (P .. Line'Last)); 1080 Menu := Find_Menu (Menu, Line (P .. E)); 1081 if Menu = null then 1082 Put_Line ("command '" & Line (P .. E) & "' not found"); 1083 end if; 1084 P := E + 1; 1085 end Parse_Command; 1086 1087 procedure Help_Proc (Line : String) 1088 is 1089 P : Natural; 1090 Root : Menu_Entry_Acc := Menu_Top'access; 1091 begin 1092 Put_Line ("This is the help command"); 1093 P := Line'First; 1094 while P < Line'Last loop 1095 Parse_Command (Line, P, Root); 1096 if Root = null then 1097 return; 1098 elsif Root.Kind /= Menu_Submenu then 1099 Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); 1100 return; 1101 end if; 1102 end loop; 1103 1104 Root := Root.First; 1105 while Root /= null loop 1106 Put (Root.Name.all); 1107 if Root.Kind = Menu_Submenu then 1108 Put (" (menu)"); 1109 end if; 1110 New_Line; 1111 Root := Root.Next; 1112 end loop; 1113 end Help_Proc; 1114 1115 procedure Debug (Reason: Debug_Reason) 1116 is 1117 use Grt.Readline; 1118 Raw_Line : Char_Ptr; 1119 Prompt : System.Address; 1120 begin 1121 Prompt := Prompt_Debug'Address; 1122 1123 case Reason is 1124 when Reason_Init => 1125 Prompt := Prompt_Init'Address; 1126 when Reason_Error => 1127 Prompt := Prompt_Error'Address; 1128 when Reason_Break => 1129 case Exec_State is 1130 when Exec_Run => 1131 if not Is_Breakpoint_Hit then 1132 return; 1133 end if; 1134 Put_Line ("breakpoint hit"); 1135 when Exec_Single_Step => 1136 null; 1137 when Exec_Next => 1138 if Current_Instance /= Exec_Instance then 1139 return; 1140 end if; 1141 when Exec_Next_Stmt => 1142 if Current_Instance /= Exec_Instance 1143 or else Is_Within_Statement (Exec_Statement, Current_Loc) 1144 then 1145 return; 1146 end if; 1147 end case; 1148 -- Default state. 1149 Exec_State := Exec_Run; 1150 1151 end case; 1152 1153 case Reason is 1154 when Reason_Error 1155 | Reason_Break => 1156 Put ("stopped at: "); 1157 Disp_Iir_Location (Current_Loc); 1158 New_Line; 1159 Disp_Source_Line (Get_Location (Current_Loc)); 1160 when others => 1161 null; 1162 end case; 1163 1164 if Current_Loc /= Null_Node then 1165 Set_List_Current (Get_Location (Current_Loc)); 1166 end if; 1167 1168 Command_Status := Status_Default; 1169 1170 loop 1171 loop 1172 Raw_Line := Readline (Prompt); 1173 -- Skip empty lines 1174 if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then 1175 if Cmd_Repeat /= null then 1176 Cmd_Repeat.all (""); 1177 case Command_Status is 1178 when Status_Default => 1179 null; 1180 when Status_Quit => 1181 return; 1182 end case; 1183 end if; 1184 else 1185 Cmd_Repeat := null; 1186 exit; 1187 end if; 1188 end loop; 1189 declare 1190 Line_Last : constant Natural := Strlen (Raw_Line); 1191 Line : String renames Raw_Line (1 .. Line_Last); 1192 P, E : Positive; 1193 Cmd : Menu_Entry_Acc := Menu_Top'Access; 1194 begin 1195 -- Find command 1196 P := 1; 1197 loop 1198 E := P; 1199 Parse_Command (Line, E, Cmd); 1200 exit when Cmd = null; 1201 case Cmd.Kind is 1202 when Menu_Submenu => 1203 if E > Line_Last then 1204 Put_Line ("missing command for submenu " 1205 & Line (P .. E - 1)); 1206 Cmd := null; 1207 exit; 1208 end if; 1209 P := E; 1210 when Menu_Command => 1211 exit; 1212 end case; 1213 end loop; 1214 1215 if Cmd /= null then 1216 Cmd.Proc.all (Line (E .. Line_Last)); 1217 1218 case Command_Status is 1219 when Status_Default => 1220 null; 1221 when Status_Quit => 1222 exit; 1223 end case; 1224 end if; 1225 exception 1226 when Command_Error => 1227 null; 1228 end; 1229 end loop; 1230 -- Put ("resuming"); 1231 end Debug; 1232 1233 procedure Debug_Init (Top : Node) is 1234 begin 1235 Current_Instance := null; 1236 Current_Loc := Top; 1237 1238 -- To avoid warnings. 1239 Exec_Statement := Null_Node; 1240 Exec_Instance := null; 1241 1242 Debug (Reason_Init); 1243 end Debug_Init; 1244 1245 procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is 1246 begin 1247 Current_Instance := Inst; 1248 Current_Loc := Stmt; 1249 1250 Debug (Reason_Break); 1251 end Debug_Break; 1252 1253 procedure Debug_Leave (Inst : Synth_Instance_Acc) is 1254 begin 1255 if Exec_Instance = Inst then 1256 -- Will be destroyed. 1257 Exec_Instance := null; 1258 1259 case Exec_State is 1260 when Exec_Run => 1261 null; 1262 when Exec_Single_Step => 1263 null; 1264 when Exec_Next 1265 | Exec_Next_Stmt => 1266 -- Leave the frame, will stop just after. 1267 Exec_State := Exec_Single_Step; 1268 end case; 1269 end if; 1270 end Debug_Leave; 1271 1272 procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is 1273 begin 1274 if Flags.Flag_Debug_Enable then 1275 Current_Instance := Inst; 1276 Current_Loc := Expr; 1277 Debug (Reason_Error); 1278 end if; 1279 end Debug_Error; 1280end Synth.Debugger; 1281