1-- GHDL Run Time (GRT) - VPI interface. 2-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram 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-- Description: VPI interface for GRT runtime 18-- the main purpose of this code is to interface with the 19-- Icarus Verilog Interactive (IVI) simulator GUI 20 21------------------------------------------------------------------------------- 22-- TODO: 23------------------------------------------------------------------------------- 24-- DONE: 25-- * The GHDL VPI implementation doesn't support time 26-- callbacks (cbReadOnlySynch). This is needed to support 27-- IVI run. Currently, the GHDL simulation runs until 28-- complete once a single 'run' is performed... 29-- * You are loading '_'-prefixed symbols when you 30-- load the vpi plugin. On Linux, there is no leading 31-- '_'. I just added code to try both '_'-prefixed and 32-- non-'_'-prefixed symbols. I have placed the changed 33-- file in the same download dir as the snapshot 34-- * I did find out why restart doesn't work for GHDL. 35-- You are passing back the leaf name of signals when the 36-- FullName is requested. 37------------------------------------------------------------------------------- 38 39with Ada.Unchecked_Deallocation; 40with System.Storage_Elements; -- Work around GNAT bug. 41pragma Unreferenced (System.Storage_Elements); 42with Grt.Stdio; use Grt.Stdio; 43with Grt.C; use Grt.C; 44with Grt.Signals; use Grt.Signals; 45with Grt.Astdio; use Grt.Astdio; 46with Grt.Astdio.Vhdl; use Grt.Astdio.Vhdl; 47with Grt.Strings; use Grt.Strings; 48with Grt.Hooks; use Grt.Hooks; 49with Grt.Options; 50with Grt.Vcd; use Grt.Vcd; 51with Grt.Errors; use Grt.Errors; 52with Grt.Rtis_Types; 53with Grt.Std_Logic_1164; use Grt.Std_Logic_1164; 54with Grt.Callbacks; use Grt.Callbacks; 55with Grt.Vstrings; use Grt.Vstrings; 56with Version; 57 58package body Grt.Vpi is 59 -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. 60 -- This is now set in Makefile, since this is target dependent. 61 -- pragma Linker_Options ("-ldl"); 62 63 --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; 64 --errNoString: constant String := "grt-vcd.adb: no string" & NUL; 65 66 Product : constant String := "GHDL" & NUL; 67 GhdlVersion : constant String := 68 Version.Ghdl_Ver & " " & Version.Ghdl_Release & NUL; 69 70 -- If true, emit traces 71 Flag_Trace : Boolean := False; 72 Trace_File : FILEs; 73 Trace_Indent : Natural := 0; 74 75------------------------------------------------------------------------------- 76-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * * 77------------------------------------------------------------------------------- 78 79 ------------------------------------------------------------------------ 80 -- debugging helpers 81 procedure dbgPut (Str : String) 82 is 83 S : size_t; 84 pragma Unreferenced (S); 85 begin 86 S := fwrite (Str'Address, Str'Length, 1, stderr); 87 end dbgPut; 88 89 procedure dbgPut (C : Character) 90 is 91 R : int; 92 pragma Unreferenced (R); 93 begin 94 R := fputc (Character'Pos (C), stderr); 95 end dbgPut; 96 97 procedure dbgNew_Line is 98 begin 99 dbgPut (Nl); 100 end dbgNew_Line; 101 102 procedure dbgPut_Line (Str : String) 103 is 104 begin 105 dbgPut (Str); 106 dbgNew_Line; 107 end dbgPut_Line; 108 109-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type) 110-- is 111-- begin 112-- Put_Str_Len(stderr, Str); 113-- dbgNew_Line; 114-- end dbgPut_Line; 115 116 procedure Free is new Ada.Unchecked_Deallocation 117 (Name => vpiHandle, Object => struct_vpiHandle); 118 119 ------------------------------------------------------------------------ 120 -- NUL-terminate strings. 121 -- note: there are several buffers 122 -- see IEEE 1364-2001 123-- tmpstring1: string(1..1024); 124-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String 125-- is 126-- begin 127-- for i in 1..Str.Len loop 128-- tmpstring1(i):= Str.Str(i); 129-- end loop; 130-- tmpstring1(Str.Len+1):= NUL; 131-- return To_Ghdl_C_String (tmpstring1'Address); 132-- end NulTerminate1; 133 134 -- Clear error status. 135 procedure Reset_Error; 136 137 procedure Trace_Start (Msg : String) is 138 begin 139 for I in 1 .. Trace_Indent loop 140 Put (Trace_File, ' '); 141 end loop; 142 Put (Trace_File, Msg); 143 end Trace_Start; 144 145 procedure Trace (Msg : String) is 146 begin 147 Put (Trace_File, Msg); 148 end Trace; 149 150 procedure Trace (V : Integer) is 151 begin 152 Put_I32 (Trace_File, Ghdl_I32 (V)); 153 end Trace; 154 155 procedure Trace_Cb_Reason (V : Integer) is 156 begin 157 case V is 158 when cbValueChange => 159 Trace ("cbValueChange"); 160 when cbReadWriteSynch => 161 Trace ("cbReadWriteSynch"); 162 when cbReadOnlySynch => 163 Trace ("cbReadOnlySynch"); 164 when cbNextSimTime => 165 Trace ("cbNextSimTime"); 166 when cbAfterDelay => 167 Trace ("cbAfterDelay"); 168 when cbEndOfCompile => 169 Trace ("cbEndOfCompile"); 170 when cbStartOfSimulation => 171 Trace ("cbStartOfSimulation"); 172 when cbEndOfSimulation => 173 Trace ("cbEndOfSimulation"); 174 when others => 175 Trace (V); 176 end case; 177 end Trace_Cb_Reason; 178 179 procedure Trace_Property (V : Integer) is 180 begin 181 case V is 182 when vpiUndefined => 183 Trace ("vpiUndefined"); 184 when vpiType => 185 Trace ("vpiType"); 186 when vpiName => 187 Trace ("vpiName"); 188 when vpiFullName => 189 Trace ("vpiFullName"); 190 when vpiSize => 191 Trace ("vpiSize"); 192 when vpiFile => 193 Trace ("vpiFile"); 194 when vpiLineNo => 195 Trace ("vpiLineNo"); 196 197 when vpiDefName => 198 Trace ("vpiDefName"); 199 when vpiTimePrecision => 200 Trace ("vpiTimePrecision"); 201 when vpiDefFile => 202 Trace ("vpiDefFile"); 203 204 -- Port and net properties 205 206 when vpiScalar => 207 Trace ("vpiScalar"); 208 when vpiVector => 209 Trace ("vpiVector"); 210 211 when vpiModule => 212 Trace ("vpiModule"); 213 when vpiNet => 214 Trace ("vpiNet"); 215 when vpiPort => 216 Trace ("vpiPort"); 217 when vpiParameter => 218 Trace ("vpiParameter"); 219 when vpiScope => 220 Trace ("vpiScope"); 221 when vpiInternalScope => 222 Trace ("vpiInternalScope"); 223 when vpiLeftRange => 224 Trace ("vpiLeftRange"); 225 when vpiRightRange => 226 Trace ("vpiRightRange"); 227 228 when vpiStop => 229 Trace ("vpiStop"); 230 when vpiFinish => 231 Trace ("vpiFinish"); 232 when vpiReset => 233 Trace ("vpiReset"); 234 235 when others => 236 Trace (V); 237 end case; 238 end Trace_Property; 239 240 procedure Trace_Format (F : Integer) is 241 begin 242 case F is 243 when vpiBinStrVal => 244 Trace ("BinStr"); 245 when vpiOctStrVal => 246 Trace ("OctStr"); 247 when vpiDecStrVal => 248 Trace ("DecStr"); 249 when vpiHexStrVal => 250 Trace ("HexStr"); 251 when vpiScalarVal => 252 Trace ("Scalar"); 253 when vpiIntVal => 254 Trace ("Int"); 255 when vpiRealVal => 256 Trace ("Real"); 257 when vpiStringVal => 258 Trace ("String"); 259 when vpiVectorVal => 260 Trace ("Vector"); 261 when vpiStrengthVal => 262 Trace ("Strength"); 263 when vpiTimeVal => 264 Trace ("Time"); 265 when vpiObjTypeVal => 266 Trace ("ObjType"); 267 when vpiSuppressVal => 268 Trace ("Suppress"); 269 270 when others => 271 Trace (F); 272 end case; 273 end Trace_Format; 274 275 procedure Trace_Time_Tag (V : Integer) is 276 begin 277 case V is 278 when vpiSimTime => 279 Trace ("vpiSimTime"); 280 when others => 281 Trace (V); 282 end case; 283 end Trace_Time_Tag; 284 285 procedure Trace (H : vpiHandle) 286 is 287 function To_Address is 288 new Ada.Unchecked_Conversion (vpiHandle, System.Address); 289 begin 290 Put (Trace_File, To_Address (H)); 291 end Trace; 292 293 procedure Trace (Str : Ghdl_C_String) is 294 begin 295 if Str = null then 296 Put (Trace_File, "null"); 297 else 298 Put (Trace_File, '"'); 299 Put (Trace_File, Str); 300 Put (Trace_File, '"'); 301 end if; 302 end Trace; 303 304 procedure Trace_Time (V : Std_Time) is 305 begin 306 Put_Time (Trace_File, V); 307 end Trace_Time; 308 309 procedure Trace_Value (V : p_vpi_value) is 310 begin 311 case V.Format is 312 when vpiBinStrVal 313 | vpiOctStrVal 314 | vpiDecStrVal 315 | vpiHexStrVal 316 | vpiStringVal => 317 Trace (V.Str); 318 when vpiScalarVal => 319 Trace (V.Scalar); 320 when vpiIntVal => 321 Trace (V.Integer_m); 322 --when vpiRealVal=> null; -- what is the equivalent to double? 323 --when vpiTimeVal=> mTime: p_vpi_time; 324 --when vpiVectorVal=> mVector: p_vpi_vecval; 325 --when vpiStrengthVal=> mStrength: p_vpi_strengthval; 326 when others => 327 null; 328 end case; 329 end Trace_Value; 330 331 procedure Trace_Newline is 332 begin 333 New_Line (Trace_File); 334 end Trace_Newline; 335 336 function Vpi_Time_To_Time (V : s_vpi_time) return Std_Time is 337 Res : Std_Time; 338 begin 339 if V.mType /= vpiSimTime then 340 raise Program_Error; 341 end if; 342 Res := Std_Time (Unsigned_64 (V.mHigh) * 2 ** 32 + Unsigned_64 (V.mLow)); 343 return Res; 344 end Vpi_Time_To_Time; 345 346------------------------------------------------------------------------------- 347-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * * 348------------------------------------------------------------------------------- 349 350 -- Free an handler, when it was not passed by reference. 351 procedure Free_Copy (H : vpiHandle) 352 is 353 Copy : vpiHandle; 354 begin 355 Copy := H; 356 Free (Copy); 357 end Free_Copy; 358 359 ------------------------------------------------------------------------ 360 -- vpiHandle vpi_iterate(int type, vpiHandle ref) 361 -- Obtain an iterator handle to objects with a one-to-many relationship. 362 -- see IEEE 1364-2001, page 685 363 function Vpi_Iterate_Internal 364 (aType: integer; Ref: vpiHandle) return vpiHandle 365 is 366 Res : vpiHandle; 367 Rel : VhpiOneToManyT; 368 Error : AvhpiErrorT; 369 begin 370 case aType is 371 when vpiPort | vpiNet => 372 Rel := VhpiDecls; 373 when vpiModule => 374 if Ref = null then 375 Res := new struct_vpiHandle (vpiModule); 376 Get_Root_Inst (Res.Ref); 377 return Res; 378 else 379 Rel := VhpiInternalRegions; 380 end if; 381 when vpiInternalScope => 382 Rel := VhpiInternalRegions; 383 when others => 384 return null; 385 end case; 386 387 -- find the proper start object for our scan 388 if Ref = null then 389 Res := null; 390 else 391 Res := new struct_vpiHandle (aType); 392 Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error); 393 394 if Error /= AvhpiErrorOk then 395 Free (Res); 396 end if; 397 end if; 398 399 return Res; 400 end Vpi_Iterate_Internal; 401 402 function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle 403 is 404 Res : vpiHandle; 405 begin 406 if Flag_Trace then 407 Trace_Start ("vpi_iterate ("); 408 Trace_Property (aType); 409 Trace (", "); 410 Trace (Ref); 411 Trace (") = "); 412 end if; 413 414 Res := Vpi_Iterate_Internal (aType, Ref); 415 416 if Flag_Trace then 417 Trace (Res); 418 Trace_Newline; 419 end if; 420 421 return Res; 422 end vpi_iterate; 423 424 ------------------------------------------------------------------------ 425 -- int vpi_get(int property, vpiHandle ref) 426 -- Get the value of an integer or boolean property of an object. 427 -- see IEEE 1364-2001, chapter 27.6, page 667 428-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer 429-- is 430-- begin 431-- case aRef.Kind is 432-- when Ghdl_Name_Entity 433-- | Ghdl_Name_Architecture 434-- | Ghdl_Name_Block 435-- | Ghdl_Name_Generate_Iterative 436-- | Ghdl_Name_Generate_Conditional 437-- | Ghdl_Name_Instance => 438-- return vpiModule; 439-- when Ghdl_Name_Signal => 440-- return vpiNet; 441-- when others => 442-- return vpiUndefined; 443-- end case; 444-- end ii_vpi_get_type; 445 446 function Vpi_Get_Size (Ref : vpiHandle) return Integer 447 is 448 Info : Verilog_Wire_Info; 449 begin 450 Get_Verilog_Wire (Ref.Ref, Info); 451 case Info.Vtype is 452 when Vcd_Var_Vectors => 453 return Natural (Get_Wire_Length (Info)); 454 when Vcd_Bool 455 | Vcd_Bit 456 | Vcd_Stdlogic => 457 return 1; 458 when Vcd_Integer32 => 459 return 32; 460 when Vcd_Enum8 => 461 return 8; 462 when Vcd_Float64 => 463 return 0; 464 when Vcd_Bad => 465 return 0; 466 end case; 467 end Vpi_Get_Size; 468 469 function Vpi_Get_Vector (Ref : vpiHandle) return Boolean 470 is 471 Info : Verilog_Wire_Info; 472 begin 473 Get_Verilog_Wire (Ref.Ref, Info); 474 case Info.Vtype is 475 when Vcd_Bool 476 | Vcd_Integer32 477 | Vcd_Float64 478 | Vcd_Bit 479 | Vcd_Stdlogic 480 | Vcd_Enum8 => 481 return False; 482 when Vcd_Bitvector 483 | Vcd_Stdlogic_Vector => 484 return True; 485 when Vcd_Bad => 486 return False; 487 end case; 488 end Vpi_Get_Vector; 489 490 function vpi_get (Property: integer; Ref: vpiHandle) return Integer 491 is 492 Res : Integer; 493 begin 494 if Flag_Trace then 495 Trace_Start ("vpi_get ("); 496 Trace_Property (Property); 497 Trace (", "); 498 Trace (Ref); 499 Trace (") = "); 500 end if; 501 502 case Property is 503 when vpiType => 504 Res := Ref.mType; 505 when vpiTimePrecision => 506 Res := -3 * Options.Time_Resolution_Scale; 507 when vpiSize => 508 Res := Vpi_Get_Size (Ref); 509 when vpiVector => 510 Res := Boolean'Pos (Vpi_Get_Vector (Ref)); 511 when vpiDirection => 512 case Vhpi_Get_Mode (Ref.Ref) is 513 when VhpiInMode => 514 Res := vpiInput; 515 when VhpiOutMode => 516 Res := vpiOutput; 517 when VhpiInoutMode => 518 Res := vpiInout; 519 when others => 520 Res := vpiNoDirection; 521 end case; 522 when others => 523 dbgPut_Line ("vpi_get: unknown property"); 524 Res := 0; 525 end case; 526 527 if Flag_Trace then 528 case Property is 529 when vpiType => 530 Trace_Property (Res); 531 when others => 532 Trace (Res); 533 end case; 534 Trace_Newline; 535 end if; 536 537 return Res; 538 end vpi_get; 539 540 function Vhpi_Handle_To_Vpi_Prop (Res : VhpiHandleT) return Integer is 541 begin 542 case Vhpi_Get_Kind (Res) is 543 when VhpiEntityDeclK 544 | VhpiArchBodyK 545 | VhpiBlockStmtK 546 | VhpiIfGenerateK 547 | VhpiForGenerateK 548 | VhpiCompInstStmtK => 549 return vpiModule; 550 when VhpiPortDeclK => 551 declare 552 Info : Verilog_Wire_Info; 553 begin 554 Get_Verilog_Wire (Res, Info); 555 if Info.Vtype /= Vcd_Bad then 556 return vpiNet; 557 end if; 558 end; 559 when VhpiSigDeclK => 560 declare 561 Info : Verilog_Wire_Info; 562 begin 563 Get_Verilog_Wire (Res, Info); 564 if Info.Vtype /= Vcd_Bad then 565 return vpiNet; 566 end if; 567 end; 568 when VhpiGenericDeclK => 569 declare 570 Info : Verilog_Wire_Info; 571 begin 572 Get_Verilog_Wire (Res, Info); 573 if Info.Vtype /= Vcd_Bad then 574 return vpiParameter; 575 end if; 576 end; 577 when VhpiConstDeclK => 578 declare 579 Info : Verilog_Wire_Info; 580 begin 581 Get_Verilog_Wire (Res, Info); 582 if Info.Vtype /= Vcd_Bad then 583 return vpiConstant; 584 end if; 585 end; 586 when others => 587 null; 588 end case; 589 return vpiUndefined; 590 end Vhpi_Handle_To_Vpi_Prop; 591 592 function Build_vpiHandle (Res : VhpiHandleT; Prop : Integer) 593 return vpiHandle is 594 begin 595 case Prop is 596 when vpiModule => 597 return new struct_vpiHandle'(mType => vpiModule, 598 Ref => Res); 599 when vpiNet => 600 return new struct_vpiHandle'(mType => vpiNet, 601 Ref => Res); 602 when vpiPort => 603 return new struct_vpiHandle'(mType => vpiPort, 604 Ref => Res); 605 when vpiParameter => 606 return new struct_vpiHandle'(mType => vpiParameter, 607 Ref => Res); 608 when vpiConstant => 609 return new struct_vpiHandle'(mType => vpiConstant, 610 Ref => Res); 611 when others => 612 return null; 613 end case; 614 end Build_vpiHandle; 615 616 ------------------------------------------------------------------------ 617 -- vpiHandle vpi_scan(vpiHandle iter) 618 -- Scan the Verilog HDL hierarchy for objects with a one-to-many 619 -- relationship. 620 -- see IEEE 1364-2001, chapter 27.36, page 709 621 function Vpi_Scan_Internal (Iter: vpiHandle) return vpiHandle 622 is 623 Res : VhpiHandleT; 624 Error : AvhpiErrorT; 625 R : vpiHandle; 626 Kind, Expected_Kind : Integer; 627 begin 628 -- End of scan reached. Avoid a crash in case of misuse. 629 if Iter = null then 630 return null; 631 end if; 632 633 -- There is only one top-level module. 634 if Iter.mType = vpiModule then 635 case Vhpi_Get_Kind (Iter.Ref) is 636 when VhpiRootInstK => 637 R := new struct_vpiHandle (Iter.mType); 638 R.Ref := Iter.Ref; 639 Iter.Ref := Null_Handle; 640 return R; 641 when VhpiUndefined => 642 -- End of iteration. 643 return null; 644 when others => 645 -- Fall through. 646 null; 647 end case; 648 end if; 649 650 case Iter.mType is 651 when vpiInternalScope 652 | vpiModule => 653 Expected_Kind := vpiModule; 654 when vpiPort => 655 Expected_Kind := vpiPort; 656 when vpiNet => 657 Expected_Kind := vpiNet; 658 when others => 659 Expected_Kind := vpiUndefined; 660 end case; 661 662 loop 663 Vhpi_Scan (Iter.Ref, Res, Error); 664 exit when Error /= AvhpiErrorOk; 665 666 Kind := Vhpi_Handle_To_Vpi_Prop (Res); 667 if Kind /= vpiUndefined 668 and then (Kind = Expected_Kind 669 or(Kind = vpiPort and Expected_Kind = vpiNet)) 670 then 671 return Build_vpiHandle (Res, Kind); 672 end if; 673 end loop; 674 675 return null; 676 end Vpi_Scan_Internal; 677 678 function vpi_scan (Iter: vpiHandle) return vpiHandle 679 is 680 Res : vpiHandle; 681 begin 682 if Flag_Trace then 683 Trace_Start ("vpi_scan ("); 684 Trace (Iter); 685 Trace (") = "); 686 end if; 687 688 Res := Vpi_Scan_Internal (Iter); 689 690 if Flag_Trace then 691 Trace (Res); 692 Trace_Newline; 693 end if; 694 695 -- IEEE 1364-2005 27.5 vpi_free_object() 696 -- The iterator object shall automatically be freed when vpi_scan() 697 -- returns NULL because it has either completed an object traversal 698 -- or encountered an error condition. 699 -- Free the iterator. 700 if Res = null then 701 Free_Copy (Iter); 702 end if; 703 704 return Res; 705 end vpi_scan; 706 707 ------------------------------------------------------------------------ 708 -- char *vpi_get_str(int property, vpiHandle ref) 709 -- see IEEE 1364-2001, page xxx 710 Tmpstring2 : String (1 .. 1024); 711 function Vpi_Get_Str_Internal (Property : Integer; Ref : vpiHandle) 712 return Ghdl_C_String 713 is 714 Prop : VhpiStrPropertyT; 715 Len : Natural; 716 Res : Ghdl_C_String; 717 begin 718 if Ref = null then 719 return null; 720 end if; 721 722 case Property is 723 when vpiFullName => 724 Prop := VhpiFullNameP; 725 when vpiName => 726 Prop := VhpiNameP; 727 when vpiType => 728 Tmpstring2 (1 .. 4) := "???" & NUL; 729 return To_Ghdl_C_String (Tmpstring2'Address); 730 when others => 731 dbgPut_Line ("vpi_get_str: unhandled property"); 732 return null; 733 end case; 734 Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len); 735 Tmpstring2 (Len + 1) := NUL; 736 if Property = vpiFullName then 737 for I in Tmpstring2'First .. Len loop 738 if Tmpstring2 (I) = ':' then 739 Tmpstring2 (I) := '.'; 740 end if; 741 end loop; 742 -- Remove the initial '.'. 743 Res := To_Ghdl_C_String (Tmpstring2 (2)'Address); 744 else 745 Res := To_Ghdl_C_String (Tmpstring2'Address); 746 end if; 747 748 return Res; 749 end Vpi_Get_Str_Internal; 750 751 function vpi_get_str (Property : Integer; Ref : vpiHandle) 752 return Ghdl_C_String 753 is 754 Res : Ghdl_C_String; 755 begin 756 if Flag_Trace then 757 Trace_Start ("vpi_get_str ("); 758 Trace_Property (Property); 759 Trace (", "); 760 Trace (Ref); 761 Trace (") = "); 762 end if; 763 764 Res := Vpi_Get_Str_Internal (Property, Ref); 765 766 if Flag_Trace then 767 Trace (Res); 768 Trace_Newline; 769 end if; 770 771 return Res; 772 end vpi_get_str; 773 ------------------------------------------------------------------------ 774 -- vpiHandle vpi_handle(int type, vpiHandle ref) 775 -- Obtain a handle to an object with a one-to-one relationship. 776 -- see IEEE 1364-2001, chapter 27.16, page 682 777 function Vpi_Handle_Internal 778 (aType : Integer; Ref : vpiHandle) return vpiHandle 779 is 780 Res : vpiHandle; 781 begin 782 if Ref = null then 783 return null; 784 end if; 785 786 case aType is 787 when vpiScope => 788 case Ref.mType is 789 when vpiModule => 790 Res := new struct_vpiHandle (vpiScope); 791 Res.Ref := Ref.Ref; 792 return Res; 793 when others => 794 return null; 795 end case; 796 when vpiRightRange 797 | vpiLeftRange => 798 case Ref.mType is 799 when vpiPort| vpiNet => 800 Res := new struct_vpiHandle (aType); 801 Res.Ref := Ref.Ref; 802 return Res; 803 when others => 804 return null; 805 end case; 806 when others => 807 return null; 808 end case; 809 end Vpi_Handle_Internal; 810 811 function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle 812 is 813 Res : vpiHandle; 814 begin 815 if Flag_Trace then 816 Trace_Start ("vpi_handle ("); 817 Trace_Property (aType); 818 Trace (", "); 819 Trace (Ref); 820 Trace (") = "); 821 end if; 822 823 Res := Vpi_Handle_Internal (aType, Ref); 824 825 if Flag_Trace then 826 Trace (Res); 827 Trace_Newline; 828 end if; 829 830 return Res; 831 end vpi_handle; 832 833 ------------------------------------------------------------------------ 834 -- void vpi_get_value(vpiHandle expr, p_vpi_value value); 835 -- Retrieve the simulation value of an object. 836 -- see IEEE 1364-2001, chapter 27.14, page 675 837 Buf_Value : Vstring; 838 839 procedure Append_Bin (V : Ghdl_U64; Ndigits : Natural) is 840 begin 841 for I in reverse 0 .. Ndigits - 1 loop 842 if (Shift_Right (V, I) and 1) /= 0 then 843 Append (Buf_Value, '1'); 844 else 845 Append (Buf_Value, '0'); 846 end if; 847 end loop; 848 end Append_Bin; 849 850 type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character; 851 Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-"; 852 853 type Map_Type_B1 is array (Ghdl_B1) of character; 854 Map_Std_B1: constant Map_Type_B1 := "01"; 855 856 function ii_vpi_get_value_bin_str (Obj : VhpiHandleT) 857 return Ghdl_C_String 858 is 859 function E8_To_Char (Val : Ghdl_E8) return Character is 860 begin 861 if Val not in Map_Type_E8'range then 862 return '?'; 863 else 864 return Map_Std_E8 (Val); 865 end if; 866 end E8_To_Char; 867 868 Info : Verilog_Wire_Info; 869 Len : Ghdl_Index_Type; 870 begin 871 case Vhpi_Get_Kind (Obj) is 872 when VhpiPortDeclK 873 | VhpiSigDeclK 874 | VhpiGenericDeclK 875 | VhpiConstDeclK => 876 null; 877 when others => 878 return null; 879 end case; 880 881 -- Get verilog compat info. 882 Get_Verilog_Wire (Obj, Info); 883 if Info.Vtype = Vcd_Bad then 884 return null; 885 end if; 886 887 Len := Get_Wire_Length (Info); 888 889 Reset (Buf_Value); -- reset string buffer 890 891 case Info.Vtype is 892 when Vcd_Bad 893 | Vcd_Float64 => 894 return null; 895 when Vcd_Enum8 => 896 declare 897 V : Ghdl_E8; 898 begin 899 V := Verilog_Wire_Val (Info).E8; 900 Append_Bin (Ghdl_U64 (V), 8); 901 end; 902 when Vcd_Integer32 => 903 declare 904 V : Ghdl_U32; 905 begin 906 V := Verilog_Wire_Val (Info).E32; 907 Append_Bin (Ghdl_U64 (V), 32); 908 end; 909 when Vcd_Bit 910 | Vcd_Bool => 911 Append (Buf_Value, Map_Std_B1 (Verilog_Wire_Val (Info).B1)); 912 when Vcd_Bitvector => 913 for J in 0 .. Len - 1 loop 914 Append (Buf_Value, Map_Std_B1 (Verilog_Wire_Val (Info, J).B1)); 915 end loop; 916 when Vcd_Stdlogic => 917 Append (Buf_Value, E8_To_Char (Verilog_Wire_Val (Info).E8)); 918 when Vcd_Stdlogic_Vector => 919 for J in 0 .. Len - 1 loop 920 Append (Buf_Value, E8_To_Char (Verilog_Wire_Val (Info, J).E8)); 921 end loop; 922 end case; 923 Append (Buf_Value, NUL); 924 return Get_C_String (Buf_Value); 925 end ii_vpi_get_value_bin_str; 926 927 procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) is 928 begin 929 if Flag_Trace then 930 Trace_Start ("vpi_get_value ("); 931 Trace (Expr); 932 Trace (", {format="); 933 Trace_Format (Value.Format); 934 Trace ("}) = "); 935 end if; 936 937 case Value.Format is 938 when vpiObjTypeVal=> 939 -- fill in the object type and value: 940 -- For an integer, vpiIntVal 941 -- For a real, vpiRealVal 942 -- For a scalar, either vpiScalar or vpiStrength 943 -- For a time variable, vpiTimeVal with vpiSimTime 944 -- For a vector, vpiVectorVal 945 dbgPut_Line ("vpi_get_value: vpiObjTypeVal"); 946 when vpiBinStrVal=> 947 Value.Str := ii_vpi_get_value_bin_str (Expr.Ref); 948 --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all); 949 when vpiOctStrVal=> 950 dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal"); 951 when vpiDecStrVal=> 952 dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal"); 953 when vpiHexStrVal=> 954 dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal"); 955 when vpiScalarVal=> 956 dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal"); 957 when vpiIntVal=> 958 case Expr.mType is 959 when vpiLeftRange 960 | vpiRightRange=> 961 declare 962 Info : Verilog_Wire_Info; 963 begin 964 Get_Verilog_Wire (Expr.Ref, Info); 965 if Info.Irange /= null then 966 if Expr.mType = vpiLeftRange then 967 Value.Integer_m := Integer (Info.Irange.I32.Left); 968 else 969 Value.Integer_m := Integer (Info.Irange.I32.Right); 970 end if; 971 else 972 Value.Integer_m := 0; 973 end if; 974 end; 975 when others=> 976 dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType"); 977 end case; 978 when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal"); 979 when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal"); 980 when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal"); 981 when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal"); 982 when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal"); 983 when others=> dbgPut_Line("vpi_get_value: unknown mFormat"); 984 end case; 985 986 if Flag_Trace then 987 Trace_Value (Value); 988 Trace_Newline; 989 end if; 990 end vpi_get_value; 991 992 ------------------------------------------------------------------------ 993 -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, 994 -- p_vpi_time when, int flags) 995 -- Alter the simulation value of an object. 996 -- see IEEE 1364-2001, chapter 27.14, page 675 997 -- FIXME 998 type Std_Ulogic_Array is array (Ghdl_Index_Type range <>) of Std_Ulogic; 999 1000 procedure Ii_Vpi_Put_Value (Info : Verilog_Wire_Info; 1001 Vec : Std_Ulogic_Array) is 1002 begin 1003 case Info.Vtype is 1004 when Vcd_Bad => 1005 return; 1006 when Vcd_Bit 1007 | Vcd_Bool 1008 | Vcd_Bitvector => 1009 for J in Vec'Range loop 1010 declare 1011 V : constant Ghdl_B1 := 1012 Ghdl_B1 (Vec (J) = '1' or Vec (J) = 'H'); 1013 begin 1014 case Info.Val is 1015 when Vcd_Effective => 1016 Ghdl_Signal_Force_Effective_B1 1017 (To_Signal_Arr_Ptr (Info.Ptr)(J), V); 1018 when Vcd_Driving => 1019 -- Force_Driving sets both the driving and the 1020 -- effective value. 1021 Ghdl_Signal_Force_Driving_B1 1022 (To_Signal_Arr_Ptr (Info.Ptr)(J), V); 1023 when Vcd_Variable => 1024 Verilog_Wire_Val (Info, J).B1 := V; 1025 end case; 1026 end; 1027 end loop; 1028 when Vcd_Stdlogic 1029 | Vcd_Stdlogic_Vector => 1030 for J in Vec'Range loop 1031 declare 1032 V : constant Ghdl_E8 := Std_Ulogic'Pos (Vec (J)); 1033 begin 1034 case Info.Val is 1035 when Vcd_Effective => 1036 Ghdl_Signal_Force_Effective_E8 1037 (To_Signal_Arr_Ptr (Info.Ptr)(J), V); 1038 when Vcd_Driving => 1039 Ghdl_Signal_Force_Driving_E8 1040 (To_Signal_Arr_Ptr (Info.Ptr)(J), V); 1041 when Vcd_Variable => 1042 Verilog_Wire_Val (Info, J).E8 := V; 1043 end case; 1044 end; 1045 end loop; 1046 when Vcd_Enum8 => 1047 declare 1048 V : Ghdl_E8; 1049 begin 1050 V := 0; 1051 for I in reverse Vec'Range loop 1052 if Vec (I) = '1' then 1053 -- Ok, handles 'X', 'Z'... like '0'. 1054 V := V or Shift_Left (1, Natural (Vec'Last - I)); 1055 end if; 1056 end loop; 1057 case Info.Val is 1058 when Vcd_Effective => 1059 Ghdl_Signal_Force_Effective_E8 1060 (To_Signal_Arr_Ptr (Info.Ptr)(0), V); 1061 when Vcd_Driving => 1062 Ghdl_Signal_Force_Driving_E8 1063 (To_Signal_Arr_Ptr (Info.Ptr)(0), V); 1064 when Vcd_Variable => 1065 Verilog_Wire_Val (Info).E8 := V; 1066 end case; 1067 end; 1068 when Vcd_Integer32 1069 | Vcd_Float64 => 1070 null; 1071 end case; 1072 end Ii_Vpi_Put_Value; 1073 1074 procedure Ii_Vpi_Put_Value_Int (Info : Verilog_Wire_Info; 1075 Len : Ghdl_Index_Type; 1076 Val : Unsigned_32) 1077 is 1078 V : Unsigned_32; 1079 Vec : Std_Ulogic_Array (0 .. Len - 1); 1080 begin 1081 V := Val; 1082 for J in reverse 0 .. Len - 1 loop 1083 if (V mod 2) = 0 then 1084 Vec (J) := '0'; 1085 else 1086 Vec (J) := '1'; 1087 end if; 1088 V := Shift_Right_Arithmetic (V, 1); 1089 end loop; 1090 Ii_Vpi_Put_Value (Info, Vec); 1091 end Ii_Vpi_Put_Value_Int; 1092 1093 procedure Ii_Vpi_Put_Value_Bin_Str (Info : Verilog_Wire_Info; 1094 Len : Ghdl_Index_Type; 1095 Str : Ghdl_C_String) 1096 is 1097 Slen : constant Natural := strlen (Str); 1098 Soff : Integer; 1099 Vec : Std_Ulogic_Array (0 .. Len - 1); 1100 V : Std_Ulogic; 1101 begin 1102 Soff := Slen; 1103 for J in reverse 0 .. Len - 1 loop 1104 Soff := Soff - 1; 1105 if Soff >= 0 then 1106 case Str (Str'First + Soff) is 1107 when 'u' | 'U' => V := 'U'; 1108 when 'x' | 'X' => V := 'X'; 1109 when '0' => V := '0'; 1110 when '1' => V := '1'; 1111 when 'z' | 'Z' => V := 'Z'; 1112 when 'w' | 'W' => V := 'W'; 1113 when 'l' | 'L' => V := 'L'; 1114 when 'h' | 'H' => V := 'H'; 1115 when '-' => V := '-'; 1116 when others => V := 'U'; 1117 end case; 1118 else 1119 V := '0'; 1120 end if; 1121 Vec (J) := V; 1122 end loop; 1123 Ii_Vpi_Put_Value (Info, Vec); 1124 end Ii_Vpi_Put_Value_Bin_Str; 1125 1126 -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, 1127 -- p_vpi_time when, int flags) 1128 function vpi_put_value (aObj : vpiHandle; 1129 aValue : p_vpi_value; 1130 aWhen : p_vpi_time; 1131 aFlags : integer) 1132 return vpiHandle 1133 is 1134 pragma Unreferenced (aWhen); 1135 pragma Unreferenced (aFlags); 1136 1137 function To_Unsigned_32 is new Ada.Unchecked_Conversion 1138 (Integer, Unsigned_32); 1139 Info : Verilog_Wire_Info; 1140 Len : Ghdl_Index_Type; 1141 begin 1142 if Flag_Trace then 1143 Trace_Start ("vpi_put_value ("); 1144 Trace (aObj); 1145 Trace (", "); 1146 Trace_Value (aValue); 1147 Trace (")"); 1148 Trace_Newline; 1149 end if; 1150 1151 Reset_Error; 1152 1153 -- A very simple write procedure for VPI. 1154 -- Basically, it accepts bin_str values and converts to appropriate 1155 -- types (only std_logic and bit values and vectors). 1156 1157 -- It'll use Set_Effective_Value procedure to update signals 1158 1159 -- Ignoring aWhen and aFlags, for now. 1160 1161 -- Check the Obj type. 1162 -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT 1163 -- when it doesnt come from a callback. 1164 case Vhpi_Get_Kind (aObj.Ref) is 1165 when VhpiPortDeclK 1166 | VhpiSigDeclK => 1167 null; 1168 when others => 1169 return null; 1170 end case; 1171 1172 -- The following code segment was copied from the 1173 -- ii_vpi_get_value function. 1174 -- Get verilog compat info. 1175 Get_Verilog_Wire (aObj.Ref, Info); 1176 if Info.Vtype = Vcd_Bad then 1177 return null; 1178 end if; 1179 1180 Len := Get_Wire_Length (Info); 1181 if Len = 0 then 1182 -- No signal. 1183 return null; 1184 end if; 1185 1186 -- Step 1: convert vpi object to internal format. 1187 -- p_vpi_handle -> Ghdl_Signal_Ptr 1188 -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic 1189 1190 -- Step 2: convert datum to appropriate type. 1191 -- Ghdl_C_String -> Value_Union 1192 1193 -- Step 3: assigns value to object using Set_Effective_Value 1194 -- call (from grt-signals) 1195 -- Set_Effective_Value(sig_ptr, conv_value); 1196 1197 -- Checks the format of aValue. Only vpiBinStrVal will be accepted 1198 -- for now. 1199 case aValue.Format is 1200 when vpiObjTypeVal => 1201 dbgPut_Line ("vpi_put_value: vpiObjTypeVal"); 1202 when vpiBinStrVal => 1203 -- Convert LEN (number of elements) to number of bits. 1204 case Info.Vtype is 1205 when Vcd_Bad => 1206 null; 1207 when Vcd_Bit 1208 | Vcd_Bool 1209 | Vcd_Bitvector 1210 | Vcd_Stdlogic 1211 | Vcd_Stdlogic_Vector => 1212 null; 1213 when Vcd_Enum8 => 1214 Len := Len * 8; 1215 when Vcd_Integer32 => 1216 Len := Len * 32; 1217 when Vcd_Float64 => 1218 Len := Len * 64; 1219 end case; 1220 Ii_Vpi_Put_Value_Bin_Str (Info, Len, aValue.Str); 1221 -- dbgPut_Line ("vpi_put_value: vpiBinStrVal"); 1222 when vpiOctStrVal => 1223 dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal"); 1224 when vpiDecStrVal => 1225 dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal"); 1226 when vpiHexStrVal => 1227 dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal"); 1228 when vpiScalarVal => 1229 dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); 1230 when vpiIntVal => 1231 Ii_Vpi_Put_Value_Int 1232 (Info, Len, To_Unsigned_32 (aValue.Integer_m)); 1233 -- dbgPut_Line ("vpi_put_value: vpiIntVal"); 1234 when vpiRealVal => 1235 dbgPut_Line("vpi_put_value: vpiRealVal"); 1236 when vpiStringVal => 1237 dbgPut_Line("vpi_put_value: vpiStringVal"); 1238 when vpiTimeVal => 1239 dbgPut_Line("vpi_put_value: vpiTimeVal"); 1240 when vpiVectorVal => 1241 dbgPut_Line("vpi_put_value: vpiVectorVal"); 1242 when vpiStrengthVal => 1243 dbgPut_Line("vpi_put_value: vpiStrengthVal"); 1244 when others => 1245 dbgPut_Line("vpi_put_value: unknown mFormat"); 1246 end case; 1247 1248 -- Must return a scheduled event caused by vpi_put_value() 1249 -- Still dont know how to do it. 1250 return null; 1251 end vpi_put_value; 1252 1253 ------------------------------------------------------------------------ 1254 -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); 1255 -- see IEEE 1364-2001, page xxx 1256 procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) 1257 is 1258 function To_Unsigned_64 is 1259 new Ada.Unchecked_Conversion (Std_Time, Unsigned_64); 1260 Res : Std_Time; 1261 V : Unsigned_64; 1262 begin 1263 if Flag_Trace then 1264 Trace_Start ("vpi_get_time ("); 1265 Trace (Obj); 1266 Trace (", {mtype="); 1267 Trace_Time_Tag (Time.mType); 1268 Trace ("}) = "); 1269 end if; 1270 1271 if Obj /= null 1272 or else Time.mType /= vpiSimTime 1273 then 1274 dbgPut_Line ("vpi_get_time: unhandled"); 1275 return; 1276 end if; 1277 1278 Res := Current_Time; 1279 1280 V := To_Unsigned_64 (Res); 1281 Time.mHigh := Unsigned_32 (V / 2 ** 32); 1282 Time.mLow := Unsigned_32 (V mod 2 ** 32); 1283 Time.mReal := 0.0; 1284 1285 if Flag_Trace then 1286 Trace_Time (Res); 1287 Trace_Newline; 1288 end if; 1289 end vpi_get_time; 1290 1291 ------------------------------------------------------------------------ 1292 1293 type Callback_List is record 1294 First, Last : vpiHandle; 1295 end record; 1296 1297 procedure Append_Callback (List : in out Callback_List; Hand : vpiHandle) is 1298 begin 1299 if List.First = null then 1300 List.First := Hand; 1301 else 1302 List.Last.Cb_Next := Hand; 1303 Hand.Cb_Prev := List.Last; 1304 end if; 1305 List.Last := Hand; 1306 Hand.Cb_Next := null; 1307 end Append_Callback; 1308 1309 procedure Execute_Callback (Hand : vpiHandle) 1310 is 1311 Res : Integer; 1312 pragma Unreferenced (Res); 1313 begin 1314 if Flag_Trace then 1315 Trace_Start ("vpi call callback "); 1316 Trace (Hand); 1317 Trace (" "); 1318 Trace_Cb_Reason (Hand.Cb.Reason); 1319 Trace_Newline; 1320 Trace_Indent := Trace_Indent + 1; 1321 end if; 1322 Res := Hand.Cb.Cb_Rtn (Hand.Cb'Access); 1323 if Flag_Trace then 1324 Trace_Indent := Trace_Indent - 1; 1325 Trace_Start ("vpi end callback "); 1326 Trace (Hand); 1327 Trace_Newline; 1328 end if; 1329 end Execute_Callback; 1330 1331 procedure Execute_Callback_List (List : Callback_List) 1332 is 1333 H, Next_H : vpiHandle; 1334 begin 1335 H := List.First; 1336 while H /= null loop 1337 Next_H := H.Cb_Next; 1338 -- The callback may destroy h. 1339 Execute_Callback (H); 1340 H := Next_H; 1341 end loop; 1342 end Execute_Callback_List; 1343 1344 -- vpiHandle vpi_register_cb(p_cb_data data) 1345 g_cbEndOfCompile : Callback_List; 1346 g_cbStartOfSimulation : Callback_List; 1347 g_cbEndOfSimulation : Callback_List; 1348 1349 function To_Address is new Ada.Unchecked_Conversion 1350 (vpiHandle, System.Address); 1351 1352 function To_vpiHandle is new Ada.Unchecked_Conversion 1353 (System.Address, vpiHandle); 1354 1355 -- Wrapper 1356 procedure Call_Callback (Arg : System.Address) 1357 is 1358 Hand : vpiHandle; 1359 begin 1360 Hand := To_vpiHandle (Arg); 1361 1362 -- Increase/decrease the reference counter as it is referenced by HAND. 1363 Hand.Cb_Refcnt := Hand.Cb_Refcnt + 1; 1364 Execute_Callback (Hand); 1365 Hand.Cb_Refcnt := Hand.Cb_Refcnt - 1; 1366 1367 -- Free handlers if called once. 1368 case Hand.Cb.Reason is 1369 when cbEndOfCompile 1370 | cbStartOfSimulation 1371 | cbEndOfSimulation 1372 | cbReadOnlySynch 1373 | cbReadWriteSynch 1374 | cbAfterDelay 1375 | cbNextSimTime => 1376 pragma Assert (Hand.Cb_Refcnt = 1); 1377 -- The handler has been removed from the queue, so the reference 1378 -- counter has to be decremented and its value must be 0. Time 1379 -- to free it. 1380 Free (Hand); 1381 when cbValueChange => 1382 -- The handler hasn't been removed from the queue, unless the 1383 -- user did it while the callback was executed. If so, the 1384 -- reference counter must now be 0 and we can free it. 1385 if Hand.Cb_Refcnt = 0 then 1386 Free (Hand); 1387 end if; 1388 when others => 1389 null; 1390 end case; 1391 end Call_Callback; 1392 1393 procedure Call_Valuechange_Callback (Arg : System.Address) 1394 is 1395 Hand : constant vpiHandle := To_vpiHandle (Arg); 1396 begin 1397 if Verilog_Wire_Event (Hand.Cb_Wire) then 1398 -- Note: the call may remove H from the list, or even 1399 -- destroy it. 1400 -- However, we assume it doesn't remove the next callback... 1401 Call_Callback (Arg); 1402 end if; 1403 end Call_Valuechange_Callback; 1404 1405 procedure Resched_Callback (Arg : System.Address) 1406 is 1407 Hand : constant vpiHandle := To_vpiHandle (Arg); 1408 begin 1409 case Hand.Cb.Reason is 1410 when cbReadOnlySynch => 1411 Register_Callback 1412 (Cb_End_Of_Time_Step, Hand.Cb_Handle, Oneshot, 1413 Call_Callback'Access, Arg); 1414 when cbReadWriteSynch => 1415 Register_Callback 1416 (Cb_Last_Known_Delta, Hand.Cb_Handle, Oneshot, 1417 Call_Callback'Access, Arg); 1418 when others => 1419 raise Program_Error; 1420 end case; 1421 end Resched_Callback; 1422 1423 function vpi_register_cb (Data : p_cb_data) return vpiHandle 1424 is 1425 Res : vpiHandle; 1426 T : Std_Time; 1427 begin 1428 if Flag_Trace then 1429 Trace_Start ("vpi_register_cb ({reason="); 1430 Trace_Cb_Reason (Data.Reason); 1431 Trace (", obj="); 1432 Trace (Data.Obj); 1433 case Data.Reason is 1434 when cbAfterDelay => 1435 Trace (", time="); 1436 Trace_Time (Vpi_Time_To_Time (Data.Time.all)); 1437 when others => 1438 null; 1439 end case; 1440 Trace ("}) = "); 1441 end if; 1442 1443 Res := new struct_vpiHandle (vpiCallback); 1444 Res.Cb := Data.all; 1445 1446 -- There is one reference to the callback as it is registered. 1447 Res.Cb_Refcnt := 1; 1448 1449 case Data.Reason is 1450 when cbEndOfCompile => 1451 Append_Callback (g_cbEndOfCompile, Res); 1452 when cbStartOfSimulation => 1453 Append_Callback (g_cbStartOfSimulation, Res); 1454 when cbEndOfSimulation => 1455 Append_Callback (g_cbEndOfSimulation, Res); 1456 when cbValueChange => 1457 Get_Verilog_Wire (Data.Obj.Ref, Res.Cb_Wire); 1458 Register_Callback 1459 (Cb_Signals_Updated, Res.Cb_Handle, Repeat, 1460 Call_Valuechange_Callback'Access, To_Address (Res)); 1461 when cbReadOnlySynch 1462 | cbReadWriteSynch => 1463 T := Vpi_Time_To_Time (Data.Time.all); 1464 if T = 0 then 1465 Resched_Callback (To_Address (Res)); 1466 else 1467 Register_Callback_At 1468 (Cb_After_Delay, Res.Cb_Handle, Current_Time + T, 1469 Resched_Callback'Access, To_Address (Res)); 1470 end if; 1471 when cbAfterDelay => 1472 T := Vpi_Time_To_Time (Data.Time.all); 1473 Register_Callback_At 1474 (Cb_After_Delay, Res.Cb_Handle, Current_Time + T, 1475 Call_Callback'Access, To_Address (Res)); 1476 when cbNextSimTime => 1477 Register_Callback 1478 (Cb_Next_Time_Step, Res.Cb_Handle, Oneshot, 1479 Call_Callback'Access, To_Address (Res)); 1480 when others => 1481 dbgPut_Line ("vpi_register_cb: unknown callback reason"); 1482 Free (Res); 1483 end case; 1484 1485 if Flag_Trace then 1486 Trace (Res); 1487 Trace_Newline; 1488 end if; 1489 1490 return Res; 1491 end vpi_register_cb; 1492 1493 -- int vpi_remove_cb(vpiHandle ref) 1494 function vpi_remove_cb (Ref : vpiHandle) return Integer 1495 is 1496 Ref_Copy : vpiHandle; 1497 Res : Integer; 1498 begin 1499 if Flag_Trace then 1500 Trace_Start ("vpi_remove_cb ("); 1501 Trace (Ref); 1502 Trace (") = "); 1503 end if; 1504 1505 Res := 1; 1506 Ref_Copy := Ref; 1507 case Ref.Cb.Reason is 1508 when cbValueChange 1509 | cbReadWriteSynch 1510 | cbReadOnlySynch => 1511 Delete_Callback (Ref.Cb_Handle); 1512 Ref.Cb_Refcnt := Ref.Cb_Refcnt - 1; 1513 if Ref.Cb_Refcnt > 0 then 1514 -- Do not free REF. 1515 Ref_Copy := null; 1516 end if; 1517 when others => 1518 Res := 0; 1519 Ref_Copy := null; 1520 end case; 1521 1522 if Flag_Trace then 1523 if Ref_Copy = null then 1524 Trace ("[not free] "); 1525 else 1526 Trace ("[free] "); 1527 end if; 1528 Trace (Res); 1529 Trace_Newline; 1530 end if; 1531 1532 Free (Ref_Copy); 1533 1534 return Res; 1535 end vpi_remove_cb; 1536 1537 -- int vpi_free_object(vpiHandle ref) 1538 function vpi_free_object (aRef: vpiHandle) return integer 1539 is 1540 Ref_Copy : vpiHandle; 1541 begin 1542 if Flag_Trace then 1543 Trace_Start ("vpi_free_object ("); 1544 Trace (aRef); 1545 Trace (")"); 1546 Trace_Newline; 1547 end if; 1548 1549 case aRef.mType is 1550 when vpiCallback => 1551 -- Callback are automatically freed. 1552 null; 1553 when others => 1554 Ref_Copy := aRef; 1555 Free (Ref_Copy); 1556 end case; 1557 1558 return 1; 1559 end vpi_free_object; 1560 1561------------------------------------------------------------------------------- 1562-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * 1563------------------------------------------------------------------------------- 1564 1565 -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) 1566 function vpi_get_vlog_info (info : p_vpi_vlog_info) return integer is 1567 function To_Address is new Ada.Unchecked_Conversion 1568 (Source => Grt.Options.Argv_Type, Target => System.Address); 1569 begin 1570 if Flag_Trace then 1571 Trace_Start ("vpi_get_vlog_info"); 1572 Trace_Newline; 1573 end if; 1574 1575 info.all := (Argc => Options.Argc, 1576 Argv => To_Address(Options.Argv), 1577 Product => To_Ghdl_C_String (Product'Address), 1578 Version => To_Ghdl_C_String (GhdlVersion'Address)); 1579 return 1; 1580 end vpi_get_vlog_info; 1581 1582 -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) 1583 function vpi_handle_by_index (aRef: vpiHandle; aIndex: integer) 1584 return vpiHandle 1585 is 1586 pragma Unreferenced (aRef); 1587 pragma Unreferenced (aIndex); 1588 begin 1589 if Flag_Trace then 1590 Trace_Start ("vpi_handle_by_index UNIMPLEMENTED!"); 1591 Trace_Newline; 1592 end if; 1593 1594 return null; 1595 end vpi_handle_by_index; 1596 1597 -- Return True iff L and R are equal. L must not have an element set to 1598 -- NUL. R must be lower case. 1599 function Strcasecmp (L : String; R : Ghdl_C_String) return Boolean is 1600 begin 1601 if L'Last < L'First - 1 then 1602 -- Handle null string. 1603 return R (1) = NUL; 1604 end if; 1605 1606 for I in L'Range loop 1607 if L (I) = NUL then 1608 -- NUL not allowed in L. 1609 return False; 1610 end if; 1611 if To_Lower (L (I)) /= R (I - L'First + 1) then 1612 return False; 1613 end if; 1614 end loop; 1615 1616 -- R is NUL terminated. 1617 return R (L'Length + 1) = NUL; 1618 end Strcasecmp; 1619 1620 procedure Find_By_Name (Scope : VhpiHandleT; 1621 Rel : VhpiOneToManyT; 1622 Name : String; 1623 Res : out VhpiHandleT; 1624 Err : out AvhpiErrorT) 1625 is 1626 It : VhpiHandleT; 1627 El_Name : Ghdl_C_String; 1628 begin 1629 Vhpi_Iterator (Rel, Scope, It, Err); 1630 if Err /= AvhpiErrorOk then 1631 return; 1632 end if; 1633 1634 loop 1635 Vhpi_Scan (It, Res, Err); 1636 1637 -- Either a real error or end of iterator. 1638 exit when Err /= AvhpiErrorOk; 1639 1640 El_Name := Avhpi_Get_Base_Name (Res); 1641 exit when El_Name /= null and then Strcasecmp (Name, El_Name); 1642 end loop; 1643 end Find_By_Name; 1644 1645 function Vpi_Handle_By_Name_Internal 1646 (Name : Ghdl_C_String; Scope : vpiHandle) return vpiHandle 1647 is 1648 B, E : Natural; 1649 Base, El : VhpiHandleT; 1650 Err : AvhpiErrorT; 1651 Prop : Integer; 1652 Res : vpiHandle; 1653 Escaped : Boolean; 1654 begin 1655 -- Extract the start point. 1656 if Scope = null then 1657 Get_Root_Scope (Base); 1658 else 1659 Base := Scope.Ref; 1660 end if; 1661 1662 B := Name'First; 1663 1664 -- Iterate on each part of Name. 1665 loop 1666 exit when Name (B) = NUL; 1667 1668 -- Extract the next part of the name. 1669 declare 1670 C : Character; 1671 begin 1672 E := B; 1673 Escaped := Name (E) = '\'; 1674 loop 1675 C := Name (E + 1); 1676 1677 -- '.' is a separator when not inside extended identifiers. 1678 exit when C = NUL or (C = '.' and not Escaped); 1679 1680 if C = '\' then 1681 -- Start or end of extended identifiers. 1682 -- '\' within an extended identifier is doubled, so like 1683 -- if there were two extended identifiers. 1684 Escaped := not Escaped; 1685 end if; 1686 E := E + 1; 1687 end loop; 1688 end; 1689 1690 -- Find name in Base, first as a decl, then as a sub-region. 1691 Find_By_Name (Base, VhpiDecls, Name (B .. E), El, Err); 1692 if Err /= AvhpiErrorOk then 1693 Find_By_Name (Base, VhpiInternalRegions, Name (B .. E), El, Err); 1694 end if; 1695 1696 if Err = AvhpiErrorOk then 1697 -- Found! 1698 Base := El; 1699 else 1700 -- Not found. 1701 return null; 1702 end if; 1703 1704 -- Next path component. 1705 B := E + 1; 1706 exit when Name (B) = NUL; 1707 pragma Assert (Name (B) = '.'); 1708 B := B + 1; 1709 end loop; 1710 1711 Prop := Vhpi_Handle_To_Vpi_Prop (Base); 1712 if Prop /= vpiUndefined then 1713 Res := Build_vpiHandle (Base, Prop); 1714 else 1715 Res := null; 1716 end if; 1717 1718 return Res; 1719 end Vpi_Handle_By_Name_Internal; 1720 1721 function vpi_handle_by_name (Name : Ghdl_C_String; Scope : vpiHandle) 1722 return vpiHandle 1723 is 1724 Res : vpiHandle; 1725 begin 1726 if Flag_Trace then 1727 Trace_Start ("vpi_handle_by_name ("); 1728 Trace (Name); 1729 Trace (", "); 1730 Trace (Scope); 1731 Trace (") = "); 1732 end if; 1733 1734 Res := Vpi_Handle_By_Name_Internal (Name, Scope); 1735 1736 if Flag_Trace then 1737 Trace (Res); 1738 Trace_Newline; 1739 end if; 1740 1741 return Res; 1742 end vpi_handle_by_name; 1743 1744 -- unsigned int vpi_mcd_close(unsigned int mcd) 1745 function vpi_mcd_close (Mcd: integer) return integer 1746 is 1747 pragma Unreferenced (Mcd); 1748 begin 1749 return 0; 1750 end vpi_mcd_close; 1751 1752 -- char *vpi_mcd_name(unsigned int mcd) 1753 function vpi_mcd_name (Mcd: integer) return integer 1754 is 1755 pragma Unreferenced (Mcd); 1756 begin 1757 return 0; 1758 end vpi_mcd_name; 1759 1760 -- unsigned int vpi_mcd_open(char *name) 1761 function vpi_mcd_open (Name : Ghdl_C_String) return Integer 1762 is 1763 pragma Unreferenced (Name); 1764 begin 1765 return 0; 1766 end vpi_mcd_open; 1767 1768 function vpi_register_systf (aSs: System.Address) return vpiHandle 1769 is 1770 pragma Unreferenced (aSs); 1771 begin 1772 if Flag_Trace then 1773 Trace_Start ("vpi_register_systf"); 1774 Trace_Newline; 1775 end if; 1776 return null; 1777 end vpi_register_systf; 1778 1779 -- missing here, see grt-cvpi.c: 1780 -- vpi_mcd_open_x 1781 -- vpi_mcd_vprintf 1782 -- vpi_mcd_fputc 1783 -- vpi_mcd_fgetc 1784 -- vpi_sim_vcontrol 1785 -- vpi_chk_error 1786 -- vpi_handle_by_name 1787 1788 Default_Message : constant String := "(no error message)" & NUL; 1789 Unknown_File : constant String := "(no file)" & NUL; 1790 1791 Err_Message : Ghdl_C_String := To_Ghdl_C_String (Default_Message'Address); 1792 Err_Code : Ghdl_C_String := null; 1793 Err_File : Ghdl_C_String := To_Ghdl_C_String (Unknown_File'Address); 1794 Err_Line : Integer := 0; 1795 Err_Status : Integer := 0; 1796 1797 procedure Reset_Error is 1798 begin 1799 Err_Message := To_Ghdl_C_String (Default_Message'Address); 1800 Err_Code := null; 1801 Err_File := To_Ghdl_C_String (Unknown_File'Address); 1802 Err_Line := 0; 1803 Err_Status := 0; 1804 end Reset_Error; 1805 1806 function vpi_chk_error (Info : p_vpi_error_info) return Integer is 1807 begin 1808 if Info /= null then 1809 Info.all := (State => vpiRun, 1810 Level => vpiError, 1811 Message => Err_Message, 1812 Product => To_Ghdl_C_String (Product'Address), 1813 Code => Err_Code, 1814 File => Err_File, 1815 Line => Err_Line); 1816 end if; 1817 return Err_Status; 1818 end vpi_chk_error; 1819 1820 function vpi_control_np (Op : Integer; Status : Integer) return Integer is 1821 begin 1822 if Flag_Trace then 1823 Trace_Start ("vpi_control ("); 1824 Trace_Property (Op); 1825 Trace (", "); 1826 Trace (Status); 1827 Trace (")"); 1828 Trace_Newline; 1829 end if; 1830 1831 case Op is 1832 when vpiFinish 1833 | vpiStop => 1834 Options.Break_Simulation := True; 1835 return 1; 1836 when others => 1837 return 0; 1838 end case; 1839 end vpi_control_np; 1840 1841------------------------------------------------------------------------------ 1842-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * 1843------------------------------------------------------------------------------ 1844 1845 -- VCD filename. 1846 Vpi_Filename : String_Access := null; 1847 1848 ------------------------------------------------------------------------ 1849 -- Return TRUE if OPT is an option for VPI. 1850 function Vpi_Option (Opt : String) return Boolean 1851 is 1852 F : constant Natural := Opt'First; 1853 begin 1854 if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then 1855 return False; 1856 end if; 1857 if Opt'Length > 6 and then Opt (F + 5) = '=' then 1858 -- Add an extra NUL character. 1859 Vpi_Filename := new String (1 .. Opt'Length - 6 + 1); 1860 Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); 1861 Vpi_Filename (Vpi_Filename'Last) := NUL; 1862 return True; 1863 elsif Opt'Length >= 11 and then Opt (F + 5 .. F + 10) = "-trace" then 1864 if Opt'Length > 11 and then Opt (F + 11) = '=' then 1865 declare 1866 Filename : String (1 .. Opt'Length - 11); 1867 Mode : constant String := "wt" & NUL; 1868 begin 1869 Filename (1 .. Filename'Last - 1) := Opt (F + 12 .. Opt'Last); 1870 Filename (Filename'Last) := NUL; 1871 Trace_File := fopen (Filename'Address, Mode'Address); 1872 if Trace_File = NULL_Stream then 1873 Error_S ("cannot open vpi trace file '"); 1874 Diag_C (Opt (F + 12 .. Opt'Last)); 1875 Error_E ("'"); 1876 return False; 1877 end if; 1878 end; 1879 elsif Opt'Length = 11 then 1880 Trace_File := stdout; 1881 else 1882 Error_S ("incorrect option '"); 1883 Diag_C (Opt); 1884 Error_E ("'"); 1885 return False; 1886 end if; 1887 Flag_Trace := True; 1888 return True; 1889 else 1890 return False; 1891 end if; 1892 end Vpi_Option; 1893 1894 ------------------------------------------------------------------------ 1895 procedure Vpi_Help is 1896 begin 1897 Put_Line (" --vpi=FILENAME load VPI module"); 1898 Put_Line (" --vpi-trace[=FILE] trace vpi calls to FILE"); 1899 end Vpi_Help; 1900 1901 ------------------------------------------------------------------------ 1902 -- Called before elaboration. 1903 1904 -- void loadVpiModule(const char* modulename) 1905 function LoadVpiModule (Filename: Address) return Integer; 1906 pragma Import (C, LoadVpiModule, "loadVpiModule"); 1907 1908 procedure Vpi_Init 1909 is 1910 begin 1911 if Vpi_Filename /= null then 1912 if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then 1913 Error ("cannot load VPI module"); 1914 end if; 1915 end if; 1916 end Vpi_Init; 1917 1918 ------------------------------------------------------------------------ 1919 -- Called after elaboration. 1920 procedure Vpi_Start 1921 is 1922 Res : Integer; 1923 pragma Unreferenced (Res); 1924 begin 1925 if Vpi_Filename = null then 1926 return; 1927 end if; 1928 1929 Grt.Rtis_Types.Search_Types_RTI; 1930 Execute_Callback_List (g_cbEndOfCompile); 1931 Execute_Callback_List (g_cbStartOfSimulation); 1932 end Vpi_Start; 1933 1934 ------------------------------------------------------------------------ 1935 -- Called at the end of the simulation. 1936 procedure Vpi_End 1937 is 1938 Res : Integer; 1939 pragma Unreferenced (Res); 1940 begin 1941 Execute_Callback_List (g_cbEndOfSimulation); 1942 Free (Buf_Value); 1943 end Vpi_End; 1944 1945 Vpi_Hooks : aliased constant Hooks_Type := 1946 (Desc => new String'("vpi: vpi compatible API"), 1947 Option => Vpi_Option'Access, 1948 Help => Vpi_Help'Access, 1949 Init => Vpi_Init'Access, 1950 Start => Vpi_Start'Access, 1951 Finish => Vpi_End'Access); 1952 1953 procedure Register is 1954 begin 1955 Register_Hooks (Vpi_Hooks'Access); 1956 end Register; 1957end Grt.Vpi; 1958