grt-signals.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  GHDL Run Time (GRT) - signals management.
--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GCC; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
with System; use System;
with System.Storage_Elements; --  Work around GNAT bug.
with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Grt.Errors; use Grt.Errors;
with Grt.Processes; use Grt.Processes;
with Grt.Options; use Grt.Options;
with Grt.Rtis_Types; use Grt.Rtis_Types;
with Grt.Disp_Signals;
with Grt.Astdio;
with Grt.Stdio;

package body Grt.Signals is
   function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean
   is
   begin
      return (Sig.Rti.Common.Mode and Ghdl_Rti_Signal_Kind_Mask)
        /= Ghdl_Rti_Signal_Kind_No;
   end Is_Signal_Guarded;

   Sig_Rti : Ghdl_Rtin_Object_Acc;
   Last_Implicit_Signal : Ghdl_Signal_Ptr;
   Current_Resolv : Resolved_Signal_Acc := null;

   function Get_Current_Mode_Signal return Mode_Signal_Type
   is
   begin
      return Mode_Signal_Type'Val
        (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Mode_Mask);
   end Get_Current_Mode_Signal;


   procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access;
                                   Ctxt : Ghdl_Rti_Access;
                                   Addr : Address)
   is
      pragma Unreferenced (Ctxt);
      pragma Unreferenced (Addr);
   begin
      Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig);
   end Ghdl_Signal_Name_Rti;

   function To_Address is new Ada.Unchecked_Conversion
     (Source => Ghdl_Signal_Ptr, Target => Address);

   function Create_Signal
     (Mode : Mode_Type;
      Init_Val : Value_Union;
      Mode_Sig : Mode_Signal_Type;
      Resolv_Proc : System.Address;
      Resolv_Inst : System.Address)
     return Ghdl_Signal_Ptr
   is
      Res : Ghdl_Signal_Ptr;
      Resolv : Resolved_Signal_Acc;
      S : Ghdl_Signal_Data (Mode_Sig);
   begin
      Sig_Table.Increment_Last;

      if Current_Resolv = null then
         if Resolv_Proc /= Null_Address then
            Resolv := new Resolved_Signal_Type'
              (Resolv_Proc => Resolv_Proc,
               Resolv_Inst => Resolv_Inst,
               Resolv_Ptr => Null_Address,
               Sig_Range => (Sig_Table.Last, Sig_Table.Last),
               Disconnect_Time => Bad_Time);
         else
            Resolv := null;
         end if;
      else
         if Resolv_Proc /= Null_Address then
            --  Only one resolution function is allowed!
            Internal_Error ("create_signal");
         end if;
         Resolv := Current_Resolv;
         if Current_Resolv.Sig_Range.Last = Sig_Table.Last then
            Current_Resolv := null;
         end if;
      end if;

      case Mode_Sig is
         when Mode_Signal_User =>
            S.Nbr_Drivers := 0;
            S.Drivers := null;
            S.Effective := null;
            S.Resolv := Resolv;
         when Mode_Conv_In
           | Mode_Conv_Out =>
            S.Conv := null;
         when Mode_Stable
           | Mode_Quiet
           | Mode_Delayed =>
            S.Time := 0;
         when Mode_Guard =>
            S.Guard_Func := null;
            S.Guard_Instance := System.Null_Address;
         when Mode_Transaction
           | Mode_End =>
            null;
      end case;

      Res := new Ghdl_Signal'(Value => Init_Val,
                              Driving_Value => Init_Val,
                              Last_Value => Init_Val,
                              --  Note: use -Std_Time'last instead of
                              --  Std_Time'First so that NOW - x'last_event
                              --  returns time'high at initialization!
                              Last_Event => -Std_Time'Last,
                              Last_Active => -Std_Time'Last,
                              Event => False,
                              Active => False,

                              Mode => Mode,
                              Flags => (Propag => Propag_None,
                                        Has_Active => False,
                                        Is_Dumped => False,
                                        Cyc_Event => False),

                              Net => No_Signal_Net,
                              Link => null,
                              Alink => null,
                              Flink => null,

                              Event_List => null,
                              Rti => Sig_Rti,

                              Nbr_Ports => 0,
                              Ports => null,

                              S => S);

      if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then
         Resolv.Resolv_Ptr := To_Address (Res);
      end if;

      case Flag_Activity is
         when Activity_All =>
            Res.Flags.Has_Active := True;
         when Activity_Minimal =>
            if (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then
               Res.Flags.Has_Active := True;
            end if;
         when Activity_None =>
            Res.Flags.Has_Active := False;
      end case;

      --  Put the signal in the table.
      Sig_Table.Table (Sig_Table.Last) := Res;

      return Res;
   end Create_Signal;

   procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is
   begin
      Sig.Value := Val;
      Sig.Driving_Value := Val;
      Sig.Last_Value := Val;
   end Ghdl_Signal_Init;

   procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr;
                                    Rti : Ghdl_Rti_Access)
   is
      S_Rti : Ghdl_Rtin_Object_Acc;
   begin
      S_Rti := To_Ghdl_Rtin_Object_Acc (Rti);
      if Flag_Activity = Activity_Minimal then
         if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then
            Sig.Flags.Has_Active := True;
         end if;
      end if;
   end Ghdl_Signal_Merge_Rti;

   procedure Ghdl_Signal_Create_Resolution (Proc : System.Address;
                                            Instance : System.Address;
                                            Sig : System.Address;
                                            Nbr_Sig : Ghdl_Index_Type)
   is
   begin
      if Current_Resolv /= null then
         Internal_Error ("Ghdl_Signal_Create_Resolution");
      end if;
      Current_Resolv := new Resolved_Signal_Type'
        (Resolv_Proc => Proc,
         Resolv_Inst => Instance,
         Resolv_Ptr => Sig,
         Sig_Range => (First => Sig_Table.Last + 1,
                       Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)),
         Disconnect_Time => Bad_Time);
   end Ghdl_Signal_Create_Resolution;

   procedure Check_New_Source (Sig : Ghdl_Signal_Ptr)
   is
      use Grt.Stdio;
      use Grt.Astdio;
   begin
      if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then
         if Sig.S.Resolv = null then
            --  LRM 4.3.1.2 Signal Declaration
            --  It is an error if, after the elaboration of a description, a
            --  signal has multiple sources and it is not a resolved signal.
            Put ("for signal: ");
            Disp_Signals.Put_Signal_Name (stderr, Sig);
            New_Line (stderr);
            Error ("several sources for unresolved signal");
            --  FIXME: display signal name.
         elsif Sig.S.Mode_Sig = Mode_Buffer and False then
            --  LRM 1.1.1.2  Ports
            --  A BUFFER port may have at most one source.

            --  FIXME: this is not true with VHDL-02.
            --  With VHDL-87/93, should also check that: any actual associated
            --  with a formal buffer port may have at most one source.
            Error ("buffer port which more than one source");
         end if;
      end if;
   end Check_New_Source;

   procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr)
   is
      type Size_T is new Integer;

      function Malloc (Size : Size_T) return Driver_Arr_Ptr;
      pragma Import (C, Malloc);

      function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T)
        return Driver_Arr_Ptr;
      pragma Import (C, Realloc);

      function Size (N : Ghdl_Index_Type) return Size_T is
      begin
         return Size_T (N * Driver_Type'Size / System.Storage_Unit);
      end Size;

      Trans : Transaction_Acc;
      Id : Process_Id;
   begin
      Id := Get_Current_Process_Id;
      if Sign.S.Nbr_Drivers = 0 then
         Check_New_Source (Sign);
         Sign.S.Drivers := Malloc (Size (1));
         Sign.S.Nbr_Drivers := 1;
      else
         -- Do not create a driver twice.
         for I in 0 .. Sign.S.Nbr_Drivers - 1 loop
            if Sign.S.Drivers (I).Proc = Id then
               return;
            end if;
         end loop;
         Check_New_Source (Sign);
         Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1;
         Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers));
      end if;
      Trans := new Transaction'(Kind => Trans_Value,
                                Time => 0,
                                Next => null,
                                Val => Sign.Value);
      Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) :=
        (First_Trans => Trans,
         Last_Trans => Trans,
         Proc => Id);
   end Ghdl_Process_Add_Driver;

   procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
   is
      type Size_T is new Integer;

      function Malloc (Size : Size_T) return Signal_Arr_Ptr;
      pragma Import (C, Malloc);

      function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T)
        return Signal_Arr_Ptr;
      pragma Import (C, Realloc);

      function Size (N : Ghdl_Index_Type) return Size_T is
      begin
         return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit);
      end Size;
   begin
      if Targ.Nbr_Ports = 0 then
         Targ.Ports := Malloc (Size (1));
         Targ.Nbr_Ports := 1;
      else
         Targ.Nbr_Ports := Targ.Nbr_Ports + 1;
         Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports));
      end if;
      Targ.Ports (Targ.Nbr_Ports - 1) := Src;
   end Append_Port;

   --  Add SRC to port list of TARG, but only if not already in this list.
   procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
   is
   begin
      for I in 1 .. Targ.Nbr_Ports loop
         if Targ.Ports (I - 1) = Src then
            return;
         end if;
      end loop;
      Append_Port (Targ, Src);
   end Add_Port;

   procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr;
                                     Src : Ghdl_Signal_Ptr)
   is
   begin
      Check_New_Source (Targ);
      Append_Port (Targ, Src);
   end Ghdl_Signal_Add_Source;

   procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr;
                                         Time : Std_Time) is
   begin
      if Sign.S.Resolv = null then
         Internal_Error ("ghdl_signal_set_disconnect: not resolved");
      end if;
      if Sign.S.Resolv.Disconnect_Time /= Bad_Time then
         Error ("disconnection already specified for signal");
      end if;
      if Time < 0 then
         Error ("disconnection time is negative");
      end if;
      Sign.S.Resolv.Disconnect_Time := Time;
   end Ghdl_Signal_Set_Disconnect;

   procedure Free is new Ada.Unchecked_Deallocation
     (Object => Transaction, Name => Transaction_Acc);

   function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type)
     return Boolean
   is
   begin
      case Mode is
         when Mode_B2 =>
            return Left.B2 = Right.B2;
         when Mode_E8 =>
            return Left.E8 = Right.E8;
         when Mode_E32 =>
            return Left.E32 = Right.E32;
         when Mode_I32 =>
            return Left.I32 = Right.I32;
         when Mode_I64 =>
            return Left.I64 = Right.I64;
         when Mode_F64 =>
            return Left.F64 = Right.F64;
      end case;
   end Value_Equal;

   function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type
   is
      Id : Process_Id;
   begin
      if Sig.S.Drivers = null then
         Error ("assignment to a signal without any driver");
      end if;
      Id := Get_Current_Process_Id;
      for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
         if Sig.S.Drivers (I).Proc = Id then
            return I;
         end if;
      end loop;