grt-processes.adb

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

--  GHDL Run Time (GRT) -  processes.
--  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 GNAT.Table;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System.Storage_Elements; --  Work around GNAT bug.
with Grt.Stack2; use Grt.Stack2;
with Grt.Disp;
with Grt.Astdio;
with Grt.Signals; use Grt.Signals;
with Grt.Errors; use Grt.Errors;
with Grt.Stacks; use Grt.Stacks;
with Grt.Options;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Utils;
with Grt.Hooks;
with Grt.Disp_Signals;
with Grt.Stdio;
with Grt.Stats;

package body Grt.Processes is
   --  Access to a process subprogram.
   type Proc_Acc is access procedure (Self : System.Address);

   --  Simply linked list for sensitivity.
   type Sensitivity_El;
   type Sensitivity_Acc is access Sensitivity_El;
   type Sensitivity_El is record
      Sig : Ghdl_Signal_Ptr;
      Next : Sensitivity_Acc;
   end record;

   Last_Time : Std_Time := Std_Time'Last;

   --  State of a process.
   type Process_State is
     (
      --  Sensitized process.  Its state cannot change.
      State_Sensitized,

      --  Verilog process, being suspended.
      State_Delayed,

      --  Non-sensitized process being suspended.
      State_Wait,

      --  Non-sensitized process being awaked by a wait timeout.  This state
      --  is transcient.
      State_Timeout,

      --  Non-sensitized process waiting until end.
      State_Dead);

   type Process_Type is record
      --  Stack for the process.
      --  This must be the first field of the record (and this is the only
      --  part visible).
      --  Must be NULL_STACK for sensitized processes.
      Stack : Stack_Type;

      --  Subprogram containing process code.
      Subprg : Proc_Acc;

      --  Instance (THIS parameter) for the subprogram.
      This : System.Address;

      --  Name of the process.
      Rti : Rti_Context;

      --  True if the process is resumed and will be run at next cycle.
      Resumed : Boolean;

      --  True if the process is postponed.
      Postponed : Boolean;

      State : Process_State;

      --  Timeout value for wait.
      Timeout : Std_Time;

      --  Sensitivity list.
      Sensitivity : Sensitivity_Acc;
   end record;
   type Process_Acc is access all Process_Type;

   --  Per 'thread' data.
   --  The process being executed.
   Cur_Proc_Id : Process_Id;

   Cur_Proc : Process_Acc;
   pragma Export (C, Cur_Proc, "grt_cur_proc");

   --  The secondary stack for the thread.
   Stack2 : Stack2_Ptr;

   package Process_Table is new GNAT.Table
     (Table_Component_Type => Process_Type,
      Table_Index_Type => Process_Id,
      Table_Low_Bound => 1,
      Table_Initial => 1,
      Table_Increment => 100);

   procedure Free is new Ada.Unchecked_Deallocation
     (Name => Sensitivity_Acc, Object => Sensitivity_El);

   procedure Init is
   begin
      Process_Table.Init;
   end Init;

   function Get_Current_Process_Id return Process_Id
   is
   begin
      return Cur_Proc_Id;
   end Get_Current_Process_Id;

   function Get_Nbr_Processes return Natural is
   begin
      return Natural (Process_Table.Last);
   end Get_Nbr_Processes;

   procedure Process_Register (This : System.Address;
                               Proc : System.Address;
                               Ctxt : Rti_Context;
                               State : Process_State;
                               Postponed : Boolean)
   is
      function To_Proc_Acc is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Proc_Acc);
      Stack : Stack_Type;
   begin
      if State /= State_Sensitized then
         Stack := Stack_Create (Proc, This);
      else
         Stack := Null_Stack;
      end if;
      Process_Table.Increment_Last;
      Process_Table.Table (Process_Table.Last) :=
        (Subprg => To_Proc_Acc (Proc),
         This => This,
         Rti => Ctxt,
         Sensitivity => null,
         Resumed => True,
         Postponed => Postponed,
         State => State,
         Timeout => Bad_Time,
         Stack => Stack);
      --  Used to create drivers.
      Cur_Proc_Id := Process_Table.Last;
   end Process_Register;

   procedure Ghdl_Process_Register
     (Instance : System.Address;
      Proc : System.Address;
      Ctxt : Ghdl_Rti_Access;
      Addr : System.Address)
   is
   begin
      Process_Register (Instance, Proc, (Addr, Ctxt), State_Timeout, False);
   end Ghdl_Process_Register;

   procedure Ghdl_Sensitized_Process_Register
     (Instance : System.Address;
      Proc : System.Address;
      Ctxt : Ghdl_Rti_Access;
      Addr : System.Address)
   is
   begin
      Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False);
   end Ghdl_Sensitized_Process_Register;

   procedure Ghdl_Postponed_Process_Register
     (Instance : System.Address;
      Proc : System.Address;
      Ctxt : Ghdl_Rti_Access;
      Addr : System.Address)
   is
   begin
      Process_Register (Instance, Proc, (Addr, Ctxt), State_Timeout, True);
   end Ghdl_Postponed_Process_Register;

   procedure Ghdl_Postponed_Sensitized_Process_Register
     (Instance : System.Address;
      Proc : System.Address;
      Ctxt : Ghdl_Rti_Access;
      Addr : System.Address)
   is
   begin
      Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True);
   end Ghdl_Postponed_Sensitized_Process_Register;

   procedure Verilog_Process_Register (This : System.Address;
                                       Proc : System.Address;
                                       Ctxt : Rti_Context)
   is
      function To_Proc_Acc is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Proc_Acc);
   begin
      Process_Table.Increment_Last;
      Process_Table.Table (Process_Table.Last) :=
        (Rti => Ctxt,
         Sensitivity => null,
         Resumed => True,
         Postponed => False,
         State => State_Sensitized,
         Timeout => Bad_Time,
         Subprg => To_Proc_Acc (Proc),
         This => This,
         Stack => Null_Stack);
      --  Used to create drivers.
      Cur_Proc_Id := Process_Table.Last;
   end Verilog_Process_Register;

   procedure Ghdl_Initial_Register (Instance : System.Address;
                                    Proc : System.Address)
   is
   begin
      Verilog_Process_Register (Instance, Proc, Null_Context);
   end Ghdl_Initial_Register;

   procedure Ghdl_Always_Register (Instance : System.Address;
                                   Proc : System.Address)
   is
   begin
      Verilog_Process_Register (Instance, Proc, Null_Context);
   end Ghdl_Always_Register;

   procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
   is
   begin
      Resume_Process_If_Event (Sig, Process_Table.Last);
   end Ghdl_Process_Add_Sensitivity;

   procedure Resume_Process (Proc : Process_Id) is
   begin
      Process_Table.Table (Proc).Resumed := True;
   end Resume_Process;

   function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
     return System.Address
   is
   begin
      return Grt.Stack2.Allocate (Stack2, Size);
   end Ghdl_Stack2_Allocate;

   function Ghdl_Stack2_Mark return Mark_Id is
   begin
      if Stack2 = Null_Stack2_Ptr then
         Stack2 := Grt.Stack2.Create;
      end if;
      return Grt.Stack2.Mark (Stack2);
   end Ghdl_Stack2_Mark;

   procedure Ghdl_Stack2_Release (Mark : Mark_Id) is
   begin
      Grt.Stack2.Release (Stack2, Mark);
   end Ghdl_Stack2_Release;

   function To_Acc is new Ada.Unchecked_Conversion
     (Source => System.Address, Target => Process_Acc);

   procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
   is
      El : Sensitivity_Acc;
   begin
      El := new Sensitivity_El'(Sig => Sig,
                                Next => Cur_Proc.Sensitivity);
      Cur_Proc.Sensitivity := El;
   end Ghdl_Process_Wait_Add_Sensitivity;

   procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time)
   is
   begin
      if Time < 0 then
         --  LRM93 8.1
         Error ("negative timeout clause");
      end if;
      Cur_Proc.Timeout := Current_Time + Time;
   end Ghdl_Process_Wait_Set_Timeout;

   function Ghdl_Process_Wait_Suspend return Boolean
   is
   begin
      if Cur_Proc.State = State_Sensitized then
         Error ("wait statement in a sensitized process");
      end if;
      --  Suspend this process.
      Cur_Proc.State := State_Wait;
--       if Cur_Proc.Timeout = Bad_Time then
--          Cur_Proc.Timeout := Std_Time'Last;
--       end if;
      Stack_Switch (Main_Stack, Cur_Proc.Stack);
      return Cur_Proc.State = State_Timeout;
   end Ghdl_Process_Wait_Suspend;

   procedure Ghdl_Process_Wait_Close
   is
      El : Sensitivity_Acc;
      N_El : Sensitivity_Acc;
   begin
      El := Cur_Proc.Sensitivity;
      Cur_Proc.Sensitivity := null;
      while El /= null loop
         N_El := El.Next;
         Free (El);
         El := N_El;
      end loop;
   end Ghdl_Process_Wait_Close;

   procedure Ghdl_Process_Wait_Exit
   is
   begin
      if Cur_Proc.State = State_Sensitized then
         Error ("wait statement in a sensitized process");
      end if;
      --  Mark this process as dead, in order to kill it.
      --  It cannot be killed now, since this code is still in the process.
      Cur_Proc.State := State_Dead;
      --  Suspend this process.
      Stack_Switch (Main_Stack, Cur_Proc.Stack);
   end Ghdl_Process_Wait_Exit;

   procedure Ghdl_Process_Wait_Timeout (Time : Std_Time)
   is
   begin
      if Cur_Proc.State = State_Sensitized then
         Error ("wait statement in a sensitized process");
      end if;
      if Time < 0 then
         --  LRM93 8.1
         Error ("negative timeout clause");
      end if;
      Cur_Proc.Timeout := Current_Time + Time;
      Cur_Proc.State := State_Wait;
      --  Suspend this process.
      Stack_Switch (Main_Stack, Cur_Proc.Stack);
   end Ghdl_Process_Wait_Timeout;

   --  Verilog.
   procedure Ghdl_Process_Delay (Del : Ghdl_U32)
   is
   begin
      Cur_Proc.Timeout := Current_Time + Std_Time (Del);
      Cur_Proc.State := State_Delayed;
   end Ghdl_Process_Delay;

   --  Protected object lock.
   --  Note: there is no real locks, since the kernel is single threading.
   --  Multi lock is allowed, and rules are just checked.
   type Object_Lock is record
      --  The owner of the lock.
      --  Nul_Process_Id means the lock is free.
      Process : Process_Id;
      --  Number of times the lock has been acquired.
      Count : Natural;
   end record;

   type Object_Lock_Acc is access Object_Lock;
   type Object_Lock_Acc_Acc is access Object_Lock_Acc;

   function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion
     (Source => System.Address, Target => Object_Lock_Acc_Acc);

   procedure Ghdl_Protected_Enter (Obj : System.Address)
   is
      Lock : Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
   begin
      if Lock.Process = Nul_Process_Id then
         if Lock.Count /= 0 then
            Internal_Error ("protected_enter");
         end if;
         Lock.Process := Get_Current_Process_Id;
         Lock.Count := 1;
      else
         if Lock.Process /= Get_Current_Process_Id then
            Internal_Error ("protected_enter(2)");
         end if;
         Lock.Count := Lock.Count + 1;
      end if;
   end Ghdl_Protected_Enter;

   procedure Ghdl_Protected_Leave (Obj : System.Address)
   is
      Lock : Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;