1-- GHDL Run Time (GRT) - wave dumper (GHW) module. 2-- Copyright (C) 2002 - 2014 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16-- 17-- As a special exception, if other files instantiate generics from this 18-- unit, or you link this unit with other files to produce an executable, 19-- this unit does not by itself cause the resulting executable to be 20-- covered by the GNU General Public License. This exception does not 21-- however invalidate any other reasons why the executable file might be 22-- covered by the GNU Public License. 23 24with System; use System; 25with Ada.Unchecked_Conversion; 26with Ada.Unchecked_Deallocation; 27with Interfaces; use Interfaces; 28with Grt.Types; use Grt.Types; 29with Grt.Avhpi; use Grt.Avhpi; 30with Grt.Stdio; use Grt.Stdio; 31with Grt.C; use Grt.C; 32with Grt.Errors; use Grt.Errors; 33with Grt.Astdio; use Grt.Astdio; 34with Grt.Callbacks; use Grt.Callbacks; 35with Grt.Hooks; use Grt.Hooks; 36with Grt.Table; 37with Grt.Avls; use Grt.Avls; 38with Grt.Rtis; use Grt.Rtis; 39with Grt.Rtis_Addr; use Grt.Rtis_Addr; 40with Grt.Rtis_Utils; 41with Grt.Rtis_Types; 42with Grt.Signals; use Grt.Signals; 43with Grt.Vstrings; use Grt.Vstrings; 44with Grt.Ghw; use Grt.Ghw; 45with Grt.Wave_Opt; use Grt.Wave_Opt; 46with Grt.Wave_Opt.File; use Grt.Wave_Opt.File; 47with Grt.Wave_Opt.Design; use Grt.Wave_Opt.Design; 48 49pragma Elaborate_All (Grt.Rtis_Utils); 50pragma Elaborate_All (Grt.Table); 51 52package body Grt.Waves is 53 -- Waves filename. 54 Wave_Filename : String_Access := null; 55 -- Stream corresponding to the GHW filename. 56 Wave_Stream : FILEs; 57 58 -- Return TRUE if OPT is an option for wave. 59 function Wave_Option (Opt : String) return Boolean 60 is 61 F : constant Natural := Opt'First; 62 begin 63 if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then 64 return False; 65 end if; 66 if Opt'Length > 6 and then Opt (F + 6) = '=' then 67 -- Add an extra NUL character. 68 Wave_Filename := new String (1 .. Opt'Length - 7 + 1); 69 Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last); 70 Wave_Filename (Wave_Filename'Last) := NUL; 71 return True; 72 else 73 return False; 74 end if; 75 end Wave_Option; 76 77 procedure Wave_Help is 78 begin 79 Put_Line (" --wave=FILENAME dump signal values into a wave file"); 80 end Wave_Help; 81 82 procedure Wave_Put (Str : String) 83 is 84 R : size_t; 85 pragma Unreferenced (R); 86 begin 87 R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); 88 end Wave_Put; 89 90 procedure Wave_Putc (C : Character) 91 is 92 R : int; 93 pragma Unreferenced (R); 94 begin 95 R := fputc (Character'Pos (C), Wave_Stream); 96 end Wave_Putc; 97 98 procedure Wave_Newline is 99 begin 100 Wave_Putc (Nl); 101 end Wave_Newline; 102 103 procedure Wave_Put_Byte (B : Unsigned_8) 104 is 105 V : Unsigned_8 := B; 106 R : size_t; 107 pragma Unreferenced (R); 108 begin 109 R := fwrite (V'Address, 1, 1, Wave_Stream); 110 end Wave_Put_Byte; 111 112 procedure Wave_Put_ULEB128 (Val : Ghdl_E32) 113 is 114 V : Ghdl_E32; 115 R : Ghdl_E32; 116 begin 117 V := Val; 118 loop 119 R := V mod 128; 120 V := V / 128; 121 if V = 0 then 122 Wave_Put_Byte (Unsigned_8 (R)); 123 exit; 124 else 125 Wave_Put_Byte (Unsigned_8 (128 + R)); 126 end if; 127 end loop; 128 end Wave_Put_ULEB128; 129 130 procedure Wave_Put_SLEB128 (Val : Ghdl_I32) 131 is 132 function To_Ghdl_U32 is new Ada.Unchecked_Conversion 133 (Ghdl_I32, Ghdl_U32); 134 V : Ghdl_U32 := To_Ghdl_U32 (Val); 135 136-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural) 137-- return Ghdl_U32; 138-- pragma Import (Intrinsic, Shift_Right_Arithmetic); 139 R : Unsigned_8; 140 begin 141 loop 142 R := Unsigned_8 (V mod 128); 143 V := Shift_Right_Arithmetic (V, 7); 144 if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) 145 then 146 Wave_Put_Byte (R); 147 exit; 148 else 149 Wave_Put_Byte (R or 16#80#); 150 end if; 151 end loop; 152 end Wave_Put_SLEB128; 153 154 procedure Wave_Put_LSLEB128 (Val : Ghdl_I64) 155 is 156 function To_Ghdl_U64 is new Ada.Unchecked_Conversion 157 (Ghdl_I64, Ghdl_U64); 158 V : Ghdl_U64 := To_Ghdl_U64 (Val); 159 160 R : Unsigned_8; 161 begin 162 loop 163 R := Unsigned_8 (V mod 128); 164 V := Shift_Right_Arithmetic (V, 7); 165 if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) 166 then 167 Wave_Put_Byte (R); 168 exit; 169 else 170 Wave_Put_Byte (R or 16#80#); 171 end if; 172 end loop; 173 end Wave_Put_LSLEB128; 174 175 procedure Wave_Put_I32 (Val : Ghdl_I32) 176 is 177 V : Ghdl_I32 := Val; 178 R : size_t; 179 pragma Unreferenced (R); 180 begin 181 R := fwrite (V'Address, 4, 1, Wave_Stream); 182 end Wave_Put_I32; 183 184 procedure Wave_Put_I64 (Val : Ghdl_I64) 185 is 186 V : Ghdl_I64 := Val; 187 R : size_t; 188 pragma Unreferenced (R); 189 begin 190 R := fwrite (V'Address, 8, 1, Wave_Stream); 191 end Wave_Put_I64; 192 193 procedure Wave_Put_F64 (F64 : Ghdl_F64) 194 is 195 V : Ghdl_F64 := F64; 196 R : size_t; 197 pragma Unreferenced (R); 198 begin 199 R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); 200 end Wave_Put_F64; 201 202 procedure Wave_Puts (Str : Ghdl_C_String) is 203 begin 204 Put (Wave_Stream, Str); 205 end Wave_Puts; 206 207 procedure Write_Value (Value : Ghdl_Value_Ptr; Mode : Mode_Type) is 208 begin 209 case Mode is 210 when Mode_B1 => 211 Wave_Put_Byte (Ghdl_B1'Pos (Value.B1)); 212 when Mode_E8 => 213 Wave_Put_Byte (Ghdl_E8'Pos (Value.E8)); 214 when Mode_E32 => 215 Wave_Put_ULEB128 (Value.E32); 216 when Mode_I32 => 217 Wave_Put_SLEB128 (Value.I32); 218 when Mode_I64 => 219 Wave_Put_LSLEB128 (Value.I64); 220 when Mode_F64 => 221 Wave_Put_F64 (Value.F64); 222 end case; 223 end Write_Value; 224 225 subtype Section_Name is String (1 .. 4); 226 type Header_Type is record 227 Name : Section_Name; 228 Pos : long; 229 end record; 230 231 package Section_Table is new Grt.Table 232 (Table_Component_Type => Header_Type, 233 Table_Index_Type => Natural, 234 Table_Low_Bound => 1, 235 Table_Initial => 16); 236 237 -- Create a new section. 238 -- Write the header in the file. 239 -- Save the location for the directory. 240 procedure Wave_Section (Name : Section_Name) is 241 begin 242 Section_Table.Append (Header_Type'(Name => Name, 243 Pos => ftell (Wave_Stream))); 244 Wave_Put (Name); 245 end Wave_Section; 246 247 procedure Wave_Write_Size_Order is 248 begin 249 -- Byte order, 1 byte. 250 -- 0: bad, 1 : little-endian, 2 : big endian. 251 declare 252 type Byte_Arr is array (0 .. 3) of Unsigned_8; 253 function To_Byte_Arr is new Ada.Unchecked_Conversion 254 (Source => Unsigned_32, Target => Byte_Arr); 255 B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#); 256 V : Unsigned_8; 257 begin 258 if B4 (0) = 16#11# then 259 -- Big endian. 260 V := 2; 261 elsif B4 (0) = 16#44# then 262 -- Little endian. 263 V := 1; 264 else 265 -- Unknown endian. 266 V := 0; 267 end if; 268 Wave_Put_Byte (V); 269 end; 270 -- Word size, 1 byte. 271 Wave_Put_Byte (Integer'Size / 8); 272 -- File offset size, 1 byte 273 Wave_Put_Byte (1); 274 -- Unused, must be zero (MBZ). 275 Wave_Put_Byte (0); 276 end Wave_Write_Size_Order; 277 278 procedure Wave_Write_Directory 279 is 280 Pos : long; 281 begin 282 Pos := ftell (Wave_Stream); 283 Wave_Section ("DIR" & NUL); 284 Wave_Write_Size_Order; 285 Wave_Put_I32 (Ghdl_I32 (Section_Table.Last)); 286 for I in Section_Table.First .. Section_Table.Last loop 287 Wave_Put (Section_Table.Table (I).Name); 288 Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos)); 289 end loop; 290 Wave_Put ("EOD" & NUL); 291 292 Wave_Section ("TAI" & NUL); 293 Wave_Write_Size_Order; 294 Wave_Put_I32 (Ghdl_I32 (Pos)); 295 end Wave_Write_Directory; 296 297 -- Called before elaboration. 298 procedure Wave_Init 299 is 300 Mode : constant String := "wb" & NUL; 301 begin 302 if Wave_Filename = null then 303 Wave_Stream := NULL_Stream; 304 return; 305 end if; 306 if Wave_Filename.all = "-" & NUL then 307 Wave_Stream := stdout; 308 else 309 Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address); 310 if Wave_Stream = NULL_Stream then 311 Error_S ("cannot open "); 312 Error_E (Wave_Filename (Wave_Filename'First 313 .. Wave_Filename'Last - 1)); 314 return; 315 end if; 316 end if; 317 end Wave_Init; 318 319 procedure Write_File_Header is 320 begin 321 -- Magic, 9 bytes. 322 Wave_Put ("GHDLwave" & Nl); 323 -- Header length. 324 Wave_Put_Byte (16); 325 -- Version-major, 1 byte. 326 Wave_Put_Byte (0); 327 -- Version-minor, 1 byte. 328 Wave_Put_Byte (1); 329 330 Wave_Write_Size_Order; 331 332 -- TODO: add time resolution. 333 end Write_File_Header; 334 335 procedure Avhpi_Error (Err : AvhpiErrorT) 336 is 337 pragma Unreferenced (Err); 338 begin 339 Put_Line ("Waves.Avhpi_Error!"); 340 null; 341 end Avhpi_Error; 342 343 package Str_Table is new Grt.Table 344 (Table_Component_Type => Ghdl_C_String, 345 Table_Index_Type => AVL_Value, 346 Table_Low_Bound => 1, 347 Table_Initial => 16); 348 349 package Str_AVL is new Grt.Table 350 (Table_Component_Type => AVL_Node, 351 Table_Index_Type => AVL_Nid, 352 Table_Low_Bound => AVL_Root, 353 Table_Initial => 16); 354 355 Strings_Len : Natural := 0; 356 357 function Str_Compare (L, R : AVL_Value) return Integer 358 is 359 Ls, Rs : Ghdl_C_String; 360 begin 361 Ls := Str_Table.Table (L); 362 Rs := Str_Table.Table (R); 363 if L = R then 364 return 0; 365 end if; 366 return Strcmp (Ls, Rs); 367 end Str_Compare; 368 369 procedure Disp_Str_Avl (N : AVL_Nid) is 370 begin 371 Put (stdout, "node: "); 372 Put_I32 (stdout, Ghdl_I32 (N)); 373 New_Line (stdout); 374 Put (stdout, " left: "); 375 Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left)); 376 New_Line (stdout); 377 Put (stdout, " right: "); 378 Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right)); 379 New_Line (stdout); 380 Put (stdout, " height: "); 381 Put_I32 (stdout, Str_AVL.Table (N).Height); 382 New_Line (stdout); 383 Put (stdout, " str: "); 384 --Put (stdout, Str_AVL.Table (N).Val); 385 New_Line (stdout); 386 end Disp_Str_Avl; 387 388 pragma Unreferenced (Disp_Str_Avl); 389 390 function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value 391 is 392 Res : AVL_Nid; 393 begin 394 Str_Table.Append (Str); 395 Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, 396 Left | Right => AVL_Nil, 397 Height => 1)); 398 Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), 399 Str_Compare'Access, 400 Str_AVL.Last, Res); 401 if Res /= Str_AVL.Last then 402 Str_AVL.Decrement_Last; 403 Str_Table.Decrement_Last; 404 else 405 Strings_Len := Strings_Len + strlen (Str); 406 end if; 407 return Str_AVL.Table (Res).Val; 408 end Create_Str_Index; 409 410 pragma Unreferenced (Create_Str_Index); 411 412 procedure Create_String_Id (Str : Ghdl_C_String) 413 is 414 Res : AVL_Nid; 415 begin 416 if Str = null then 417 return; 418 end if; 419 Str_Table.Append (Str); 420 Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, 421 Left | Right => AVL_Nil, 422 Height => 1)); 423 Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), 424 Str_Compare'Access, 425 Str_AVL.Last, Res); 426 if Res /= Str_AVL.Last then 427 Str_AVL.Decrement_Last; 428 Str_Table.Decrement_Last; 429 else 430 Strings_Len := Strings_Len + strlen (Str); 431 end if; 432 end Create_String_Id; 433 434 function Get_String (Str : Ghdl_C_String) return AVL_Value 435 is 436 H, L, M : AVL_Value; 437 Diff : Integer; 438 begin 439 L := Str_Table.First; 440 H := Str_Table.Last; 441 loop 442 M := (L + H) / 2; 443 Diff := Strcmp (Str, Str_Table.Table (M)); 444 if Diff = 0 then 445 return M; 446 elsif Diff < 0 then 447 H := M - 1; 448 else 449 L := M + 1; 450 end if; 451 exit when L > H; 452 end loop; 453 return 0; 454 end Get_String; 455 456 procedure Write_String_Id (Str : Ghdl_C_String) is 457 begin 458 if Str = null then 459 Wave_Put_Byte (0); 460 else 461 Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str))); 462 end if; 463 end Write_String_Id; 464 465 type Type_Node is record 466 Type_Rti : Ghdl_Rti_Access; 467 Context : Rti_Context; 468 end record; 469 470 package Types_Table is new Grt.Table 471 (Table_Component_Type => Type_Node, 472 Table_Index_Type => AVL_Value, 473 Table_Low_Bound => 1, 474 Table_Initial => 16); 475 476 package Types_AVL is new Grt.Table 477 (Table_Component_Type => AVL_Node, 478 Table_Index_Type => AVL_Nid, 479 Table_Low_Bound => AVL_Root, 480 Table_Initial => 16); 481 482 function Type_Compare (L, R : AVL_Value) return Integer 483 is 484 function To_Ia is new 485 Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); 486 487 function "<" (L, R : Ghdl_Rti_Access) return Boolean is 488 begin 489 return To_Ia (L) < To_Ia (R); 490 end "<"; 491 492 Ls : Type_Node renames Types_Table.Table (L); 493 Rs : Type_Node renames Types_Table.Table (R); 494 begin 495 if Ls.Type_Rti /= Rs.Type_Rti then 496 if Ls.Type_Rti < Rs.Type_Rti then 497 return -1; 498 else 499 return 1; 500 end if; 501 end if; 502 if Ls.Context.Block /= Rs.Context.Block then 503 if Ls.Context.Block < Rs.Context.Block then 504 return -1; 505 else 506 return +1; 507 end if; 508 end if; 509 if Ls.Context.Base /= Rs.Context.Base then 510 if Ls.Context.Base < Rs.Context.Base then 511 return -1; 512 else 513 return +1; 514 end if; 515 end if; 516 return 0; 517 end Type_Compare; 518 519 -- Try to find type (RTI, CTXT) in the types_AVL table. 520 -- The first step is to canonicalize CTXT, so that it is the CTXT of 521 -- the type (and not a sub-scope of it). 522 procedure Find_Type (Rti : Ghdl_Rti_Access; 523 Ctxt : Rti_Context; 524 N_Ctxt : out Rti_Context; 525 Id : out AVL_Nid) 526 is 527 Depth : Ghdl_Rti_Depth; 528 begin 529 case Rti.Kind is 530 when Ghdl_Rtik_Type_B1 531 | Ghdl_Rtik_Type_E8 => 532 N_Ctxt := Null_Context; 533 when Ghdl_Rtik_Port 534 | Ghdl_Rtik_Signal => 535 N_Ctxt := Ctxt; 536 when others => 537 -- Compute the canonical context. 538 if Rti.Max_Depth < Rti.Depth then 539 Internal_Error ("grt.waves.find_type"); 540 end if; 541 Depth := Rti.Max_Depth; 542 if Depth = 0 or else Ctxt.Block = null then 543 N_Ctxt := Null_Context; 544 else 545 N_Ctxt := Ctxt; 546 while N_Ctxt.Block.Depth > Depth loop 547 N_Ctxt := Get_Parent_Context (N_Ctxt); 548 end loop; 549 end if; 550 end case; 551 552 -- If the type is already known, return now. 553 -- Otherwise, ID is set to AVL_Nil. 554 Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt)); 555 Id := Find_Node 556 (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), 557 Type_Compare'Access, 558 Types_Table.Last); 559 Types_Table.Decrement_Last; 560 end Find_Type; 561 562 procedure Write_Type_Id (Tid : AVL_Nid) is 563 begin 564 Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val)); 565 end Write_Type_Id; 566 567 procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) 568 is 569 N_Ctxt : Rti_Context; 570 Res : AVL_Nid; 571 begin 572 Find_Type (Rti, Ctxt, N_Ctxt, Res); 573 if Res = AVL_Nil then 574 -- raise Program_Error; 575 Internal_Error ("write_type_id"); 576 end if; 577 Write_Type_Id (Res); 578 end Write_Type_Id; 579 580 procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) 581 is 582 Res : AVL_Nid; 583 begin 584 -- Then, create the type. 585 Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt)); 586 Types_AVL.Append (AVL_Node'(Val => Types_Table.Last, 587 Left | Right => AVL_Nil, 588 Height => 1)); 589 590 Get_Node 591 (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), 592 Type_Compare'Access, 593 Types_AVL.Last, Res); 594 if Res /= Types_AVL.Last then 595 --raise Program_Error; 596 Internal_Error ("wave.create_type(2)"); 597 end if; 598 end Add_Type; 599 600 procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) 601 is 602 N_Ctxt : Rti_Context; 603 Res : AVL_Nid; 604 begin 605 Find_Type (Rti, Ctxt, N_Ctxt, Res); 606 if Res /= AVL_Nil then 607 return; 608 end if; 609 610 -- First, create all the types it depends on. 611 case Rti.Kind is 612 when Ghdl_Rtik_Type_B1 613 | Ghdl_Rtik_Type_E8 => 614 declare 615 Enum : constant Ghdl_Rtin_Type_Enum_Acc := 616 To_Ghdl_Rtin_Type_Enum_Acc (Rti); 617 begin 618 Create_String_Id (Enum.Name); 619 for I in 1 .. Enum.Nbr loop 620 Create_String_Id (Enum.Names (I - 1)); 621 end loop; 622 end; 623 when Ghdl_Rtik_Type_I32 624 | Ghdl_Rtik_Type_I64 625 | Ghdl_Rtik_Type_F64 => 626 declare 627 Base : constant Ghdl_Rtin_Type_Scalar_Acc := 628 To_Ghdl_Rtin_Type_Scalar_Acc (Rti); 629 begin 630 Create_String_Id (Base.Name); 631 end; 632 when Ghdl_Rtik_Type_P32 633 | Ghdl_Rtik_Type_P64 => 634 declare 635 Base : constant Ghdl_Rtin_Type_Physical_Acc := 636 To_Ghdl_Rtin_Type_Physical_Acc (Rti); 637 Unit_Name : Ghdl_C_String; 638 begin 639 Create_String_Id (Base.Name); 640 for I in 1 .. Base.Nbr loop 641 Unit_Name := 642 Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1)); 643 Create_String_Id (Unit_Name); 644 end loop; 645 end; 646 when Ghdl_Rtik_Subtype_Scalar => 647 declare 648 Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := 649 To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); 650 begin 651 Create_String_Id (Sub.Name); 652 Create_Type (Sub.Basetype, N_Ctxt); 653 end; 654 when Ghdl_Rtik_Type_Array => 655 declare 656 Arr : constant Ghdl_Rtin_Type_Array_Acc := 657 To_Ghdl_Rtin_Type_Array_Acc (Rti); 658 begin 659 Create_String_Id (Arr.Name); 660 Create_Type (Arr.Element, N_Ctxt); 661 for I in 1 .. Arr.Nbr_Dim loop 662 Create_Type (Arr.Indexes (I - 1), N_Ctxt); 663 end loop; 664 end; 665 when Ghdl_Rtik_Type_Record 666 | Ghdl_Rtik_Type_Unbounded_Record => 667 declare 668 Rec : constant Ghdl_Rtin_Type_Record_Acc := 669 To_Ghdl_Rtin_Type_Record_Acc (Rti); 670 El : Ghdl_Rtin_Element_Acc; 671 begin 672 Create_String_Id (Rec.Name); 673 for I in 1 .. Rec.Nbrel loop 674 El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); 675 Create_String_Id (El.Name); 676 Create_Type (El.Eltype, N_Ctxt); 677 end loop; 678 end; 679 when Ghdl_Rtik_Subtype_Array 680 | Ghdl_Rtik_Subtype_Record 681 | Ghdl_Rtik_Subtype_Unbounded_Record 682 | Ghdl_Rtik_Subtype_Unbounded_Array => 683 declare 684 Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := 685 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 686 B_Ctxt : Rti_Context; 687 begin 688 Create_String_Id (Arr.Name); 689 if Rti_Complex_Type (Rti) then 690 B_Ctxt := Ctxt; 691 else 692 B_Ctxt := N_Ctxt; 693 end if; 694 Create_Type (Arr.Basetype, B_Ctxt); 695 end; 696 when others => 697 Internal_Error ("wave.create_type"); 698-- Internal_Error ("wave.create_type: does not handle " & 699-- Ghdl_Rtik'Image (Rti.Kind)); 700 end case; 701 702 -- Then, create the type. 703 Add_Type (Rti, N_Ctxt); 704 end Create_Type; 705 706 procedure Create_Object_Type (Obj : VhpiHandleT) 707 is 708 Obj_Type : VhpiHandleT; 709 Error : AvhpiErrorT; 710 Rti : Ghdl_Rti_Access; 711 begin 712 -- Extract type of the signal. 713 Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); 714 if Error /= AvhpiErrorOk then 715 Avhpi_Error (Error); 716 return; 717 end if; 718 Rti := Avhpi_Get_Rti (Obj_Type); 719 Create_Type (Rti, Avhpi_Get_Context (Obj_Type)); 720 721 -- The the signal type is an unbounded type, also put the object 722 -- in the type AVL. This is for unbounded ports. 723 -- The real type will be written to the file. 724 case Rti.Kind is 725 when Ghdl_Rtik_Type_Array 726 | Ghdl_Rtik_Subtype_Unbounded_Array 727 | Ghdl_Rtik_Type_Unbounded_Record 728 | Ghdl_Rtik_Subtype_Unbounded_Record => 729 Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); 730 when others => 731 null; 732 end case; 733 end Create_Object_Type; 734 735 procedure Write_Object_Type (Obj : VhpiHandleT) 736 is 737 Obj_Type : VhpiHandleT; 738 Error : AvhpiErrorT; 739 Rti : Ghdl_Rti_Access; 740 begin 741 -- Extract type of the signal. 742 Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); 743 if Error /= AvhpiErrorOk then 744 Avhpi_Error (Error); 745 return; 746 end if; 747 Rti := Avhpi_Get_Rti (Obj_Type); 748 case Rti.Kind is 749 when Ghdl_Rtik_Type_Array 750 | Ghdl_Rtik_Subtype_Unbounded_Array 751 | Ghdl_Rtik_Type_Unbounded_Record 752 | Ghdl_Rtik_Subtype_Unbounded_Record => 753 Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); 754 when others => 755 Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type)); 756 end case; 757 end Write_Object_Type; 758 759 procedure Create_Generate_Type (Gen : VhpiHandleT) 760 is 761 Iterator : VhpiHandleT; 762 Error : AvhpiErrorT; 763 begin 764 -- Extract the iterator. 765 Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error); 766 if Error /= AvhpiErrorOk then 767 Avhpi_Error (Error); 768 return; 769 end if; 770 Create_Object_Type (Iterator); 771 end Create_Generate_Type; 772 773 procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT) 774 is 775 Iter : VhpiHandleT; 776 Iter_Type : VhpiHandleT; 777 Error : AvhpiErrorT; 778 Addr : Address; 779 Mode : Mode_Type; 780 Rti : Ghdl_Rti_Access; 781 begin 782 -- Extract the iterator. 783 Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error); 784 if Error /= AvhpiErrorOk then 785 Avhpi_Error (Error); 786 return; 787 end if; 788 Write_Object_Type (Iter); 789 790 Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error); 791 if Error /= AvhpiErrorOk then 792 Avhpi_Error (Error); 793 return; 794 end if; 795 Rti := Avhpi_Get_Rti (Iter_Type); 796 Addr := Avhpi_Get_Address (Iter); 797 798 case Get_Base_Type (Rti).Kind is 799 when Ghdl_Rtik_Type_B1 => 800 Mode := Mode_B1; 801 when Ghdl_Rtik_Type_E8 => 802 Mode := Mode_E8; 803 when Ghdl_Rtik_Type_E32 => 804 Mode := Mode_E32; 805 when Ghdl_Rtik_Type_I32 => 806 Mode := Mode_I32; 807 when Ghdl_Rtik_Type_I64 => 808 Mode := Mode_I64; 809 when Ghdl_Rtik_Type_F64 => 810 Mode := Mode_F64; 811 when others => 812 Internal_Error ("bad iterator type"); 813 end case; 814 Write_Value (To_Ghdl_Value_Ptr (Addr), Mode); 815 end Write_Generate_Type_And_Value; 816 817 type Step_Type is (Step_Name, Step_Hierarchy); 818 819 Nbr_Scopes : Natural := 0; 820 Nbr_Scope_Signals : Natural := 0; 821 Nbr_Dumped_Signals : Natural := 0; 822 823 -- This is only valid during write_hierarchy. 824 function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural 825 is 826 function To_Integer_Address is new Ada.Unchecked_Conversion 827 (Ghdl_Signal_Ptr, Integer_Address); 828 begin 829 return Natural (To_Integer_Address (Sig.Alink)); 830 end Get_Signal_Number; 831 832 procedure Write_Signal_Number (Val_Addr : Address; 833 Val_Name : Vstring; 834 Val_Type : Ghdl_Rti_Access; 835 Param_Type : Natural) 836 is 837 pragma Unreferenced (Val_Name); 838 pragma Unreferenced (Val_Type); 839 pragma Unreferenced (Param_Type); 840 841 Num : Natural; 842 843 function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion 844 (Source => Integer_Address, Target => Ghdl_Signal_Ptr); 845 Sig : Ghdl_Signal_Ptr; 846 begin 847 -- Convert to signal. 848 Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); 849 850 -- Get signal number. 851 Num := Get_Signal_Number (Sig); 852 853 -- If the signal number is 0, then assign a valid signal number. 854 if Num = 0 then 855 Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1; 856 Sig.Alink := To_Ghdl_Signal_Ptr 857 (Integer_Address (Nbr_Dumped_Signals)); 858 Num := Nbr_Dumped_Signals; 859 end if; 860 861 -- Do the real job: write the signal number. 862 Wave_Put_ULEB128 (Ghdl_E32 (Num)); 863 end Write_Signal_Number; 864 865 procedure Foreach_Scalar_Signal_Number is new 866 Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, 867 Process => Write_Signal_Number); 868 869 procedure Write_Signal_Numbers (Decl : VhpiHandleT) 870 is 871 Ctxt : Rti_Context; 872 Sig : Ghdl_Rtin_Object_Acc; 873 begin 874 Ctxt := Avhpi_Get_Context (Decl); 875 Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl)); 876 Foreach_Scalar_Signal_Number 877 (Ctxt, Sig.Obj_Type, 878 Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0); 879 end Write_Signal_Numbers; 880 881 procedure Write_Hierarchy_El (Decl : VhpiHandleT) 882 is 883 Mode2hie : constant array (VhpiModeT) of Unsigned_8 := 884 (VhpiErrorMode => Ghw_Hie_Signal, 885 VhpiInMode => Ghw_Hie_Port_In, 886 VhpiOutMode => Ghw_Hie_Port_Out, 887 VhpiInoutMode => Ghw_Hie_Port_Inout, 888 VhpiBufferMode => Ghw_Hie_Port_Buffer, 889 VhpiLinkageMode => Ghw_Hie_Port_Linkage); 890 V : Unsigned_8; 891 begin 892 case Vhpi_Get_Kind (Decl) is 893 when VhpiPortDeclK => 894 V := Mode2hie (Vhpi_Get_Mode (Decl)); 895 when VhpiSigDeclK => 896 V := Ghw_Hie_Signal; 897 when VhpiForGenerateK => 898 V := Ghw_Hie_Generate_For; 899 when VhpiIfGenerateK => 900 V := Ghw_Hie_Generate_If; 901 when VhpiBlockStmtK => 902 V := Ghw_Hie_Block; 903 when VhpiCompInstStmtK => 904 V := Ghw_Hie_Instance; 905 when VhpiProcessStmtK => 906 V := Ghw_Hie_Process; 907 when VhpiPackInstK => 908 V := Ghw_Hie_Package; 909 when VhpiRootInstK => 910 V := Ghw_Hie_Instance; 911 when others => 912 --raise Program_Error; 913 Internal_Error ("write_hierarchy_el"); 914 end case; 915 Wave_Put_Byte (V); 916 Write_String_Id (Avhpi_Get_Base_Name (Decl)); 917 case Vhpi_Get_Kind (Decl) is 918 when VhpiPortDeclK 919 | VhpiSigDeclK => 920 Write_Object_Type (Decl); 921 Write_Signal_Numbers (Decl); 922 when VhpiForGenerateK => 923 Write_Generate_Type_And_Value (Decl); 924 when others => 925 null; 926 end case; 927 end Write_Hierarchy_El; 928 929 -- Create a hierarchy block. 930 procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; 931 Step : Step_Type; 932 Match_List : Design.Match_List); 933 934 procedure Wave_Put_Hierarchy_1 935 (Inst : VhpiHandleT; Step : Step_Type; Match_List : Design.Match_List) 936 is 937 Decl_It : VhpiHandleT; 938 Decl : VhpiHandleT; 939 Error : AvhpiErrorT; 940 Match_List_Child : Design.Match_List; 941 begin 942 Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); 943 if Error /= AvhpiErrorOk then 944 Avhpi_Error (Error); 945 return; 946 end if; 947 948 -- Extract signals. 949 loop 950 Vhpi_Scan (Decl_It, Decl, Error); 951 exit when Error = AvhpiErrorIteratorEnd; 952 if Error /= AvhpiErrorOk then 953 Avhpi_Error (Error); 954 return; 955 end if; 956 957 case Vhpi_Get_Kind (Decl) is 958 when VhpiPortDeclK 959 | VhpiSigDeclK => 960 Match_List_Child := Get_Cursor 961 (Match_List, Avhpi_Get_Base_Name (Decl), Is_Signal => True); 962 if Is_Displayed (Match_List_Child) then 963 case Step is 964 when Step_Name => 965 Create_String_Id (Avhpi_Get_Base_Name (Decl)); 966 Nbr_Scope_Signals := Nbr_Scope_Signals + 1; 967 Create_Object_Type (Decl); 968 when Step_Hierarchy => 969 Write_Hierarchy_El (Decl); 970 end case; 971 end if; 972 --Wave_Put_Name (Decl); 973 --Wave_Newline; 974 when others => 975 null; 976 end case; 977 end loop; 978 979 -- No sub-scopes for packages. 980 if Vhpi_Get_Kind (Inst) = VhpiPackInstK then 981 return; 982 end if; 983 984 -- Extract sub-scopes. 985 Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); 986 if Error /= AvhpiErrorOk then 987 Avhpi_Error (Error); 988 return; 989 end if; 990 991 loop 992 Vhpi_Scan (Decl_It, Decl, Error); 993 exit when Error = AvhpiErrorIteratorEnd; 994 if Error /= AvhpiErrorOk then 995 Avhpi_Error (Error); 996 return; 997 end if; 998 999 Nbr_Scopes := Nbr_Scopes + 1; 1000 1001 Match_List_Child := Get_Cursor 1002 (Match_List, Avhpi_Get_Base_Name (Decl)); 1003 if Is_Displayed (Match_List_Child) then 1004 case Vhpi_Get_Kind (Decl) is 1005 when VhpiIfGenerateK 1006 | VhpiForGenerateK 1007 | VhpiBlockStmtK 1008 | VhpiCompInstStmtK => 1009 Wave_Put_Hierarchy_Block (Decl, Step, Match_List_Child); 1010 when VhpiProcessStmtK => 1011 case Step is 1012 when Step_Name => 1013 Create_String_Id (Avhpi_Get_Base_Name (Decl)); 1014 when Step_Hierarchy => 1015 Write_Hierarchy_El (Decl); 1016 end case; 1017 when others => 1018 Internal_Error ("wave_put_hierarchy_1"); 1019 -- Wave_Put ("unknown "); 1020 -- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl))); 1021 -- Wave_Newline; 1022 end case; 1023 end if; 1024 end loop; 1025 end Wave_Put_Hierarchy_1; 1026 1027 procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; 1028 Step : Step_Type; 1029 Match_List : Design.Match_List) is 1030 begin 1031 case Step is 1032 when Step_Name => 1033 Create_String_Id (Avhpi_Get_Base_Name (Inst)); 1034 if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then 1035 Create_Generate_Type (Inst); 1036 end if; 1037 when Step_Hierarchy => 1038 Write_Hierarchy_El (Inst); 1039 end case; 1040 1041 Wave_Put_Hierarchy_1 (Inst, Step, Match_List); 1042 1043 if Step = Step_Hierarchy then 1044 Wave_Put_Byte (Ghw_Hie_Eos); 1045 end if; 1046 end Wave_Put_Hierarchy_Block; 1047 1048 procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type) 1049 is 1050 Pack_It : VhpiHandleT; 1051 Pack : VhpiHandleT; 1052 Error : AvhpiErrorT; 1053 Match_List : Design.Match_List; 1054 begin 1055 -- First packages. 1056 Get_Package_Inst (Pack_It); 1057 loop 1058 Vhpi_Scan (Pack_It, Pack, Error); 1059 exit when Error = AvhpiErrorIteratorEnd; 1060 if Error /= AvhpiErrorOk then 1061 Avhpi_Error (Error); 1062 return; 1063 end if; 1064 Match_List := Get_Top_Cursor (Pkg, Avhpi_Get_Base_Name (Pack)); 1065 if Is_Displayed (Match_List) then 1066 Wave_Put_Hierarchy_Block (Pack, Step, Match_List); 1067 end if; 1068 end loop; 1069 1070 -- Then top entity. 1071 Match_List := Get_Top_Cursor (Entity, Avhpi_Get_Base_Name (Root)); 1072 if Is_Displayed (Match_List) then 1073 Wave_Put_Hierarchy_Block (Root, Step, Match_List); 1074 end if; 1075 end Wave_Put_Hierarchy; 1076 1077 procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural) 1078 is 1079 begin 1080 if Str = AVL_Nil then 1081 return; 1082 end if; 1083 Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1); 1084 for I in 1 .. Indent loop 1085 Wave_Putc (' '); 1086 end loop; 1087 Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val)); 1088-- Wave_Putc ('('); 1089-- Put_I32 (Wave_Stream, Ghdl_I32 (Str)); 1090-- Wave_Putc (')'); 1091-- Put_I32 (Wave_Stream, Get_Height (Str)); 1092 Wave_Newline; 1093 Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1); 1094 end Disp_Str_AVL; 1095 1096 procedure Write_Strings 1097 is 1098 begin 1099-- Wave_Put ("AVL height: "); 1100-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root))); 1101-- Wave_Newline; 1102 Wave_Put ("strings length: "); 1103 Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len)); 1104 Wave_Newline; 1105 Disp_Str_AVL (AVL_Root, 0); 1106 fflush (Wave_Stream); 1107 end Write_Strings; 1108 1109 pragma Unreferenced (Write_Strings); 1110 1111 procedure Freeze_Strings 1112 is 1113 type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; 1114 type Str_Table1_Acc is access Str_Table1_Type; 1115 Idx : AVL_Value; 1116 Table1 : Str_Table1_Acc; 1117 1118 procedure Free is new Ada.Unchecked_Deallocation 1119 (Str_Table1_Type, Str_Table1_Acc); 1120 1121 procedure Store_Strings (N : AVL_Nid) is 1122 begin 1123 if N = AVL_Nil then 1124 return; 1125 end if; 1126 Store_Strings (Str_AVL.Table (N).Left); 1127 Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val); 1128 Idx := Idx + 1; 1129 Store_Strings (Str_AVL.Table (N).Right); 1130 end Store_Strings; 1131 begin 1132 Table1 := new Str_Table1_Type; 1133 Idx := 1; 1134 Store_Strings (AVL_Root); 1135 Str_Table.Release; 1136 Str_AVL.Free; 1137 for I in Table1.all'Range loop 1138 Str_Table.Table (I) := Table1 (I); 1139 end loop; 1140 Free (Table1); 1141 end Freeze_Strings; 1142 1143 procedure Write_Strings_Compress 1144 is 1145 Last : Ghdl_C_String; 1146 V : Ghdl_C_String; 1147 L : Natural; 1148 L1 : Natural; 1149 begin 1150 Wave_Section ("STR" & NUL); 1151 Wave_Put_Byte (0); 1152 Wave_Put_Byte (0); 1153 Wave_Put_Byte (0); 1154 Wave_Put_Byte (0); 1155 Wave_Put_I32 (Ghdl_I32 (Str_Table.Last)); 1156 Wave_Put_I32 (Ghdl_I32 (Strings_Len)); 1157 for I in Str_Table.First .. Str_Table.Last loop 1158 V := Str_Table.Table (I); 1159 if I = Str_Table.First then 1160 L := 1; 1161 else 1162 Last := Str_Table.Table (I - 1); 1163 1164 for I in Positive loop 1165 if V (I) /= Last (I) then 1166 L := I; 1167 exit; 1168 end if; 1169 end loop; 1170 L1 := L - 1; 1171 loop 1172 if L1 >= 32 then 1173 Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#); 1174 else 1175 Wave_Put_Byte (Unsigned_8 (L1 mod 32)); 1176 end if; 1177 L1 := L1 / 32; 1178 exit when L1 = 0; 1179 end loop; 1180 end if; 1181 1182 if Boolean'(False) then 1183 Put ("string "); 1184 Put_I32 (stdout, Ghdl_I32 (I)); 1185 Put (": "); 1186 Put (V); 1187 New_Line; 1188 end if; 1189 1190 loop 1191 exit when V (L) = NUL; 1192 Wave_Putc (V (L)); 1193 L := L + 1; 1194 end loop; 1195 end loop; 1196 -- Last string length. 1197 Wave_Put_Byte (0); 1198 -- End marker. 1199 Wave_Put ("EOS" & NUL); 1200 end Write_Strings_Compress; 1201 1202 -- Convert rtik (for types). 1203 function Ghdl_Rtik_To_Ghw_Rtik (Kind : Ghdl_Rtik) return Ghw_Rtik is 1204 begin 1205 case Kind is 1206 when Ghdl_Rtik_Type_B1 => 1207 return Ghw_Rtik_Type_B2; 1208 when Ghdl_Rtik_Type_E8 => 1209 return Ghw_Rtik_Type_E8; 1210 when Ghdl_Rtik_Subtype_Array => 1211 return Ghw_Rtik_Subtype_Array; 1212 when Ghdl_Rtik_Type_Array => 1213 return Ghw_Rtik_Type_Array; 1214 when Ghdl_Rtik_Subtype_Unbounded_Array => 1215 return Ghw_Rtik_Subtype_Unbounded_Array; 1216 when Ghdl_Rtik_Type_Record 1217 | Ghdl_Rtik_Type_Unbounded_Record => 1218 return Ghw_Rtik_Type_Record; 1219 when Ghdl_Rtik_Subtype_Record => 1220 return Ghw_Rtik_Subtype_Record; 1221 when Ghdl_Rtik_Subtype_Unbounded_Record => 1222 return Ghw_Rtik_Subtype_Unbounded_Record; 1223 when Ghdl_Rtik_Subtype_Scalar => 1224 return Ghw_Rtik_Subtype_Scalar; 1225 when Ghdl_Rtik_Type_I32 => 1226 return Ghw_Rtik_Type_I32; 1227 when Ghdl_Rtik_Type_I64 => 1228 return Ghw_Rtik_Type_I64; 1229 when Ghdl_Rtik_Type_F64 => 1230 return Ghw_Rtik_Type_F64; 1231 when Ghdl_Rtik_Type_P32 => 1232 return Ghw_Rtik_Type_P32; 1233 when Ghdl_Rtik_Type_P64 => 1234 return Ghw_Rtik_Type_P64; 1235 when others => 1236 Internal_Error ("waves.ghdl_rtik_to_ghw_rtik: unhandled kind"); 1237 end case; 1238 end Ghdl_Rtik_To_Ghw_Rtik; 1239 1240 procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) 1241 is 1242 Kind : Ghdl_Rtik; 1243 K : Unsigned_8; 1244 begin 1245 Kind := Rti.Kind; 1246 if Kind = Ghdl_Rtik_Subtype_Scalar then 1247 Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind; 1248 end if; 1249 K := Ghw_Rtik'Pos (Ghdl_Rtik_To_Ghw_Rtik (Kind)); 1250 case Kind is 1251 when Ghdl_Rtik_Type_B1 => 1252 Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#); 1253 Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left)); 1254 Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right)); 1255 when Ghdl_Rtik_Type_E8 => 1256 Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#); 1257 Wave_Put_Byte (Unsigned_8 (Rng.E8.Left)); 1258 Wave_Put_Byte (Unsigned_8 (Rng.E8.Right)); 1259 when Ghdl_Rtik_Type_I32 1260 | Ghdl_Rtik_Type_P32 => 1261 Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#); 1262 Wave_Put_SLEB128 (Rng.I32.Left); 1263 Wave_Put_SLEB128 (Rng.I32.Right); 1264 when Ghdl_Rtik_Type_P64 1265 | Ghdl_Rtik_Type_I64 => 1266 Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#); 1267 Wave_Put_LSLEB128 (Rng.P64.Left); 1268 Wave_Put_LSLEB128 (Rng.P64.Right); 1269 when Ghdl_Rtik_Type_F64 => 1270 Wave_Put_Byte (K + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#); 1271 Wave_Put_F64 (Rng.F64.Left); 1272 Wave_Put_F64 (Rng.F64.Right); 1273 when others => 1274 Internal_Error ("waves.write_range: unhandled kind"); 1275 --Internal_Error ("waves.write_range: unhandled kind " 1276 -- & Ghdl_Rtik'Image (Kind)); 1277 end case; 1278 end Write_Range; 1279 1280 procedure Write_Composite_Bounds (Rti : Ghdl_Rti_Access; Bounds : Address) 1281 is 1282 begin 1283 case Rti.Kind is 1284 when Ghdl_Rtik_Type_E8 1285 | Ghdl_Rtik_Type_E32 1286 | Ghdl_Rtik_Type_B1 1287 | Ghdl_Rtik_Type_I32 1288 | Ghdl_Rtik_Type_I64 1289 | Ghdl_Rtik_Type_P32 1290 | Ghdl_Rtik_Type_P64 1291 | Ghdl_Rtik_Type_F64 => 1292 return; 1293 when Ghdl_Rtik_Type_Array => 1294 declare 1295 Arr : constant Ghdl_Rtin_Type_Array_Acc := 1296 To_Ghdl_Rtin_Type_Array_Acc (Rti); 1297 Rng : Ghdl_Range_Ptr; 1298 Index_Type : Ghdl_Rti_Access; 1299 El_Type : Ghdl_Rti_Access; 1300 Bounds1 : Address; 1301 begin 1302 Bounds1 := Bounds; 1303 for I in 0 .. Arr.Nbr_Dim - 1 loop 1304 Index_Type := Get_Base_Type (Arr.Indexes (I)); 1305 Extract_Range (Bounds1, Index_Type, Rng); 1306 Write_Range (Index_Type, Rng); 1307 end loop; 1308 -- Write bounds only if the element subtype of the base type 1309 -- is unbounded. 1310 El_Type := Arr.Element; 1311 if Rtis_Utils.Is_Unbounded (El_Type) then 1312 El_Type := Get_Base_Type (El_Type); 1313 Bounds1 := Array_Layout_To_Element (Bounds1, El_Type); 1314 Write_Composite_Bounds (El_Type, Bounds1); 1315 end if; 1316 end; 1317 when Ghdl_Rtik_Type_Record => 1318 return; 1319 when Ghdl_Rtik_Type_Unbounded_Record => 1320 declare 1321 Rec : constant Ghdl_Rtin_Type_Record_Acc := 1322 To_Ghdl_Rtin_Type_Record_Acc (Rti); 1323 El : Ghdl_Rtin_Element_Acc; 1324 El_Type : Ghdl_Rti_Access; 1325 Bounds1 : Address; 1326 begin 1327 for I in 1 .. Rec.Nbrel loop 1328 El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); 1329 -- Write bounds only if the element subtype of the base 1330 -- type is unbounded. 1331 El_Type := El.Eltype; 1332 if Rtis_Utils.Is_Unbounded (El_Type) then 1333 El_Type := Get_Base_Type (El_Type); 1334 Bounds1 := Array_Layout_To_Element 1335 (Bounds + El.Layout_Off, El_Type); 1336 Write_Composite_Bounds (El_Type, Bounds1); 1337 end if; 1338 end loop; 1339 end; 1340 when others => 1341 Internal_Error ("waves.write_composite_bounds"); 1342 end case; 1343 end Write_Composite_Bounds; 1344 1345 procedure Write_Types 1346 is 1347 subtype Ghw_Rtik_Types is Ghw_Rtik 1348 range Ghw_Rtik_Type_B2 .. Ghw_Rtik_Subtype_Unbounded_Record; 1349 Kind : Ghw_Rtik_Types; 1350 Rti : Ghdl_Rti_Access; 1351 Ctxt : Rti_Context; 1352 begin 1353 -- Types header. 1354 Wave_Section ("TYP" & NUL); 1355 Wave_Put_Byte (0); 1356 Wave_Put_Byte (0); 1357 Wave_Put_Byte (0); 1358 Wave_Put_Byte (0); 1359 Wave_Put_I32 (Ghdl_I32 (Types_Table.Last)); 1360 1361 for I in Types_Table.First .. Types_Table.Last loop 1362 Rti := Types_Table.Table (I).Type_Rti; 1363 Ctxt := Types_Table.Table (I).Context; 1364 1365 if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then 1366 -- Declare types for unbounded objects. 1367 declare 1368 Obj_Rti : constant Ghdl_Rtin_Object_Acc := 1369 To_Ghdl_Rtin_Object_Acc (Rti); 1370 begin 1371 case Obj_Rti.Obj_Type.Kind is 1372 when Ghdl_Rtik_Type_Array => 1373 declare 1374 Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type; 1375 Addr : Ghdl_Uc_Array_Acc; 1376 begin 1377 Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array)); 1378 Write_String_Id (null); 1379 Write_Type_Id (Typ, Ctxt); 1380 Addr := To_Ghdl_Uc_Array_Acc 1381 (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); 1382 Write_Composite_Bounds (Typ, Addr.Bounds); 1383 end; 1384 when Ghdl_Rtik_Subtype_Unbounded_Array => 1385 declare 1386 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 1387 To_Ghdl_Rtin_Subtype_Composite_Acc 1388 (Obj_Rti.Obj_Type); 1389 Addr : Ghdl_Uc_Array_Acc; 1390 begin 1391 Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array)); 1392 Write_String_Id (null); 1393 Write_Type_Id (St.Basetype, Ctxt); 1394 Addr := To_Ghdl_Uc_Array_Acc 1395 (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); 1396 Write_Composite_Bounds (Get_Base_Type (St.Basetype), 1397 Addr.Bounds); 1398 end; 1399 when Ghdl_Rtik_Type_Unbounded_Record => 1400 declare 1401 Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type; 1402 Addr : Ghdl_Uc_Array_Acc; 1403 begin 1404 Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record)); 1405 Write_String_Id (null); 1406 Write_Type_Id (Typ, Ctxt); 1407 Addr := To_Ghdl_Uc_Array_Acc 1408 (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); 1409 Write_Composite_Bounds (Typ, Addr.Bounds); 1410 end; 1411 when Ghdl_Rtik_Subtype_Unbounded_Record => 1412 declare 1413 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 1414 To_Ghdl_Rtin_Subtype_Composite_Acc 1415 (Obj_Rti.Obj_Type); 1416 Addr : Ghdl_Uc_Array_Acc; 1417 begin 1418 Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record)); 1419 Write_String_Id (null); 1420 Write_Type_Id (St.Basetype, Ctxt); 1421 Addr := To_Ghdl_Uc_Array_Acc 1422 (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); 1423 Write_Composite_Bounds (Get_Base_Type (St.Basetype), 1424 Addr.Bounds); 1425 end; 1426 when others => 1427 Internal_Error ("waves.write_types: unhandled obj kind"); 1428 end case; 1429 end; 1430 else 1431 -- Kind. 1432 Kind := Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind); 1433 Wave_Put_Byte (Ghw_Rtik_Types'Pos (Kind)); 1434 1435 case Rti.Kind is 1436 when Ghdl_Rtik_Type_B1 1437 | Ghdl_Rtik_Type_E8 => 1438 declare 1439 Enum : constant Ghdl_Rtin_Type_Enum_Acc := 1440 To_Ghdl_Rtin_Type_Enum_Acc (Rti); 1441 begin 1442 Write_String_Id (Enum.Name); 1443 Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr)); 1444 for I in 1 .. Enum.Nbr loop 1445 Write_String_Id (Enum.Names (I - 1)); 1446 end loop; 1447 end; 1448 when Ghdl_Rtik_Type_I32 1449 | Ghdl_Rtik_Type_I64 1450 | Ghdl_Rtik_Type_F64 => 1451 declare 1452 Base : constant Ghdl_Rtin_Type_Scalar_Acc := 1453 To_Ghdl_Rtin_Type_Scalar_Acc (Rti); 1454 begin 1455 Write_String_Id (Base.Name); 1456 end; 1457 when Ghdl_Rtik_Type_P32 1458 | Ghdl_Rtik_Type_P64 => 1459 declare 1460 Base : constant Ghdl_Rtin_Type_Physical_Acc := 1461 To_Ghdl_Rtin_Type_Physical_Acc (Rti); 1462 Unit : Ghdl_Rti_Access; 1463 begin 1464 Write_String_Id (Base.Name); 1465 Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); 1466 for I in 1 .. Base.Nbr loop 1467 Unit := Base.Units (I - 1); 1468 Write_String_Id 1469 (Rtis_Utils.Get_Physical_Unit_Name (Unit)); 1470 case Unit.Kind is 1471 when Ghdl_Rtik_Unit64 => 1472 Wave_Put_LSLEB128 1473 (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); 1474 when Ghdl_Rtik_Unitptr => 1475 case Rti.Kind is 1476 when Ghdl_Rtik_Type_P64 => 1477 Wave_Put_LSLEB128 1478 (To_Ghdl_Rtin_Unitptr_Acc (Unit). 1479 Addr.I64); 1480 when Ghdl_Rtik_Type_P32 => 1481 Wave_Put_SLEB128 1482 (To_Ghdl_Rtin_Unitptr_Acc (Unit). 1483 Addr.I32); 1484 when others => 1485 Internal_Error 1486 ("wave.write_types(P32/P64-1)"); 1487 end case; 1488 when others => 1489 Internal_Error 1490 ("wave.write_types(P32/P64-2)"); 1491 end case; 1492 end loop; 1493 end; 1494 when Ghdl_Rtik_Subtype_Scalar => 1495 declare 1496 Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := 1497 To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); 1498 begin 1499 Write_String_Id (Sub.Name); 1500 Write_Type_Id (Sub.Basetype, Ctxt); 1501 Write_Range 1502 (Sub.Basetype, 1503 To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, 1504 Sub.Range_Loc, 1505 Ctxt))); 1506 end; 1507 when Ghdl_Rtik_Type_Array => 1508 declare 1509 Arr : constant Ghdl_Rtin_Type_Array_Acc := 1510 To_Ghdl_Rtin_Type_Array_Acc (Rti); 1511 begin 1512 Write_String_Id (Arr.Name); 1513 Write_Type_Id (Arr.Element, Ctxt); 1514 Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim)); 1515 for I in 1 .. Arr.Nbr_Dim loop 1516 Write_Type_Id (Arr.Indexes (I - 1), Ctxt); 1517 end loop; 1518 end; 1519 when Ghdl_Rtik_Subtype_Array => 1520 declare 1521 Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := 1522 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 1523 Layout : Address; 1524 begin 1525 Write_String_Id (Arr.Name); 1526 Write_Type_Id (Arr.Basetype, Ctxt); 1527 Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt); 1528 Write_Composite_Bounds (Get_Base_Type (Arr.Basetype), 1529 Array_Layout_To_Bounds (Layout)); 1530 end; 1531 when Ghdl_Rtik_Type_Record 1532 | Ghdl_Rtik_Type_Unbounded_Record => 1533 declare 1534 Rec : constant Ghdl_Rtin_Type_Record_Acc := 1535 To_Ghdl_Rtin_Type_Record_Acc (Rti); 1536 El : Ghdl_Rtin_Element_Acc; 1537 begin 1538 Write_String_Id (Rec.Name); 1539 Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel)); 1540 for I in 1 .. Rec.Nbrel loop 1541 El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); 1542 Write_String_Id (El.Name); 1543 Write_Type_Id (El.Eltype, Ctxt); 1544 end loop; 1545 end; 1546 when Ghdl_Rtik_Subtype_Record => 1547 declare 1548 Rec : constant Ghdl_Rtin_Subtype_Composite_Acc := 1549 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 1550 Base : Ghdl_Rti_Access; 1551 Layout : Address; 1552 begin 1553 Write_String_Id (Rec.Name); 1554 Write_Type_Id (Rec.Basetype, Ctxt); 1555 Base := Get_Base_Type (Rec.Basetype); 1556 if Base.Kind = Ghdl_Rtik_Type_Unbounded_Record then 1557 Layout := Loc_To_Addr 1558 (Rec.Common.Depth, Rec.Layout, Ctxt); 1559 Write_Composite_Bounds (Base, Layout); 1560 end if; 1561 end; 1562 when Ghdl_Rtik_Subtype_Unbounded_Record 1563 | Ghdl_Rtik_Subtype_Unbounded_Array => 1564 declare 1565 Rec : constant Ghdl_Rtin_Subtype_Composite_Acc := 1566 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 1567 begin 1568 Write_String_Id (Rec.Name); 1569 Write_Type_Id (Rec.Basetype, Ctxt); 1570 end; 1571 when others => 1572 Internal_Error ("wave.write_types"); 1573 -- Internal_Error ("wave.write_types: does not handle " & 1574 -- Ghdl_Rtik'Image (Rti.Kind)); 1575 end case; 1576 end if; 1577 end loop; 1578 Wave_Put_Byte (0); 1579 end Write_Types; 1580 1581 procedure Write_Known_Types 1582 is 1583 use Grt.Rtis_Types; 1584 1585 Boolean_Type_Id : AVL_Nid; 1586 Bit_Type_Id : AVL_Nid; 1587 Std_Ulogic_Type_Id : AVL_Nid; 1588 1589 function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid 1590 is 1591 Ctxt : Rti_Context; 1592 Tid : AVL_Nid; 1593 begin 1594 Find_Type (Rti, Null_Context, Ctxt, Tid); 1595 return Tid; 1596 end Search_Type_Id; 1597 begin 1598 Search_Types_RTI; 1599 1600 Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr); 1601 1602 Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr); 1603 1604 if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then 1605 Std_Ulogic_Type_Id := Search_Type_Id 1606 (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr); 1607 else 1608 Std_Ulogic_Type_Id := AVL_Nil; 1609 end if; 1610 1611 Wave_Section ("WKT" & NUL); 1612 Wave_Put_Byte (0); 1613 Wave_Put_Byte (0); 1614 Wave_Put_Byte (0); 1615 Wave_Put_Byte (0); 1616 1617 if Boolean_Type_Id /= AVL_Nil then 1618 Wave_Put_Byte (1); 1619 Write_Type_Id (Boolean_Type_Id); 1620 end if; 1621 1622 if Bit_Type_Id /= AVL_Nil then 1623 Wave_Put_Byte (2); 1624 Write_Type_Id (Bit_Type_Id); 1625 end if; 1626 1627 if Std_Ulogic_Type_Id /= AVL_Nil then 1628 Wave_Put_Byte (3); 1629 Write_Type_Id (Std_Ulogic_Type_Id); 1630 end if; 1631 1632 Wave_Put_Byte (0); 1633 end Write_Known_Types; 1634 1635 -- Table of signals to be dumped. 1636 package Dump_Table is new Grt.Table 1637 (Table_Component_Type => Ghdl_Signal_Ptr, 1638 Table_Index_Type => Natural, 1639 Table_Low_Bound => 1, 1640 Table_Initial => 32); 1641 1642 function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is 1643 begin 1644 return Dump_Table.Table (N); 1645 end Get_Dump_Entry; 1646 1647 pragma Unreferenced (Get_Dump_Entry); 1648 1649 procedure Write_Hierarchy (Root : VhpiHandleT) 1650 is 1651 N : Natural; 1652 begin 1653 -- Check Alink is 0. 1654 for I in Sig_Table.First .. Sig_Table.Last loop 1655 if Sig_Table.Table (I).Alink /= null then 1656 Internal_Error ("wave.write_hierarchy"); 1657 end if; 1658 end loop; 1659 1660 Wave_Section ("HIE" & NUL); 1661 Wave_Put_Byte (0); 1662 Wave_Put_Byte (0); 1663 Wave_Put_Byte (0); 1664 Wave_Put_Byte (0); 1665 Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes)); 1666 Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals)); 1667 Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); 1668 Wave_Put_Hierarchy (Root, Step_Hierarchy); 1669 Wave_Put_Byte (0); 1670 1671 Dump_Table.Set_Last (Nbr_Dumped_Signals); 1672 for I in Dump_Table.First .. Dump_Table.Last loop 1673 Dump_Table.Table (I) := null; 1674 end loop; 1675 1676 -- Save and clear. 1677 for I in Sig_Table.First .. Sig_Table.Last loop 1678 N := Get_Signal_Number (Sig_Table.Table (I)); 1679 if N /= 0 then 1680 if Dump_Table.Table (N) /= null then 1681 Internal_Error ("wave.write_hierarchy(2)"); 1682 end if; 1683 Dump_Table.Table (N) := Sig_Table.Table (I); 1684 Sig_Table.Table (I).Alink := null; 1685 end if; 1686 end loop; 1687 end Write_Hierarchy; 1688 1689 procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is 1690 begin 1691 -- FIXME: for some signals, the significant value is the driving value! 1692 Write_Value (Sig.Value_Ptr, Sig.Mode); 1693 end Write_Signal_Value; 1694 1695 procedure Write_Snapshot is 1696 begin 1697 Wave_Section ("SNP" & NUL); 1698 Wave_Put_Byte (0); 1699 Wave_Put_Byte (0); 1700 Wave_Put_Byte (0); 1701 Wave_Put_Byte (0); 1702 Wave_Put_I64 (Ghdl_I64 (Current_Time)); 1703 1704 for I in Dump_Table.First .. Dump_Table.Last loop 1705 Write_Signal_Value (Dump_Table.Table (I)); 1706 end loop; 1707 Wave_Put ("ESN" & NUL); 1708 end Write_Snapshot; 1709 1710 procedure Wave_Start_Cb (Arg : System.Address) 1711 is 1712 pragma Unreferenced (Arg); 1713 begin 1714 Write_Snapshot; 1715 end Wave_Start_Cb; 1716 1717 procedure Wave_Cycle; 1718 1719 -- Called after elaboration. 1720 procedure Wave_Start 1721 is 1722 Root : VhpiHandleT; 1723 H : Callback_Handle; 1724 begin 1725 -- Do nothing if there is no VCD file to generate. 1726 if Wave_Stream = NULL_Stream then 1727 return; 1728 end if; 1729 1730 Write_File_Header; 1731 1732 -- FIXME: write infos 1733 -- * date 1734 -- * timescale 1735 -- * design name ? 1736 -- ... 1737 1738 -- Put hierarchy. 1739 Get_Root_Inst (Root); 1740 -- Vcd_Search_Packages; 1741 Wave_Put_Hierarchy (Root, Step_Name); 1742 1743 Wave_Opt.File.Finalize; 1744 1745 if Str_Table.Last > 0 then 1746 Freeze_Strings; 1747 end if; 1748 1749 -- Register_Cycle_Hook (Vcd_Cycle'Access); 1750 Write_Strings_Compress; 1751 Write_Types; 1752 Write_Known_Types; 1753 Write_Hierarchy (Root); 1754 1755 Wave_Opt.Design.Last_Checks; 1756 1757 -- End of header mark. 1758 Wave_Section ("EOH" & NUL); 1759 1760 -- Write the first snapshot just before running processes for the first 1761 -- time. At that point, signals are fully initialized. 1762 Register_Callback (Cb_Start_Of_Processes, H, Oneshot, 1763 Wave_Start_Cb'Access); 1764 1765 Register_Cycle_Hook (Wave_Cycle'Access); 1766 1767 fflush (Wave_Stream); 1768 end Wave_Start; 1769 1770 Wave_Time : Std_Time := 0; 1771 In_Cyc : Boolean := False; 1772 1773 procedure Wave_Close_Cyc 1774 is 1775 begin 1776 Wave_Put_LSLEB128 (-1); 1777 Wave_Put ("ECY" & NUL); 1778 In_Cyc := False; 1779 end Wave_Close_Cyc; 1780 1781 procedure Wave_Cycle 1782 is 1783 Diff : Std_Time; 1784 Sig : Ghdl_Signal_Ptr; 1785 Last : Natural; 1786 begin 1787 if not In_Cyc then 1788 Wave_Section ("CYC" & NUL); 1789 Wave_Put_I64 (Ghdl_I64 (Current_Time)); 1790 In_Cyc := True; 1791 else 1792 Diff := Current_Time - Wave_Time; 1793 Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); 1794 end if; 1795 Wave_Time := Current_Time; 1796 1797 -- Dump signals. 1798 Last := 0; 1799 for I in Dump_Table.First .. Dump_Table.Last loop 1800 Sig := Dump_Table.Table (I); 1801 if Sig.Flags.RO_Event then 1802 Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); 1803 Last := I; 1804 Write_Signal_Value (Sig); 1805 Sig.Flags.RO_Event := False; 1806 end if; 1807 end loop; 1808 Wave_Put_Byte (0); 1809 end Wave_Cycle; 1810 1811 -- Called at the end of the simulation. 1812 procedure Wave_End is 1813 begin 1814 if Wave_Stream = NULL_Stream then 1815 return; 1816 end if; 1817 if In_Cyc then 1818 Wave_Close_Cyc; 1819 end if; 1820 Wave_Write_Directory; 1821 fclose (Wave_Stream); 1822 end Wave_End; 1823 1824 Wave_Hooks : aliased constant Hooks_Type := 1825 (Desc => new String'("ghw: save waveforms in ghw file format"), 1826 Option => Wave_Option'Access, 1827 Help => Wave_Help'Access, 1828 Init => Wave_Init'Access, 1829 Start => Wave_Start'Access, 1830 Finish => Wave_End'Access); 1831 1832 procedure Register is 1833 begin 1834 Register_Hooks (Wave_Hooks'Access); 1835 end Register; 1836end Grt.Waves; 1837