diff options
Diffstat (limited to 'src/vhdl/simulate/simul-simulation.adb')
| -rw-r--r-- | src/vhdl/simulate/simul-simulation.adb | 716 |
1 files changed, 716 insertions, 0 deletions
diff --git a/src/vhdl/simulate/simul-simulation.adb b/src/vhdl/simulate/simul-simulation.adb new file mode 100644 index 000000000..cc8c4aa51 --- /dev/null +++ b/src/vhdl/simulate/simul-simulation.adb @@ -0,0 +1,716 @@ +-- Interpreted simulation +-- Copyright (C) 2014 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Simul.Execution; use Simul.Execution; +with Areapools; use Areapools; +with Grt.Signals; +with Grt.Processes; +with Grtlink; +pragma Unreferenced (Grtlink); + +package body Simul.Simulation is + + function Value_To_Iir_Value (Mode : Mode_Type; Val : Value_Union) + return Iir_Value_Literal_Acc is + begin + case Mode is + when Mode_B1 => + return Create_B1_Value (Val.B1); + when Mode_E8 => + return Create_E8_Value (Val.E8); + when Mode_E32 => + return Create_E32_Value (Val.E32); + when Mode_I64 => + return Create_I64_Value (Val.I64); + when Mode_F64 => + return Create_F64_Value (Val.F64); + when others => + raise Internal_Error; -- FIXME + end case; + end Value_To_Iir_Value; + + procedure Iir_Value_To_Value (Src : Iir_Value_Literal_Acc; + Dst : out Value_Union) is + begin + case Iir_Value_Scalars (Src.Kind) is + when Iir_Value_B1 => + Dst.B1 := Src.B1; + when Iir_Value_E8 => + Dst.E8 := Src.E8; + when Iir_Value_E32 => + Dst.E32 := Src.E32; + when Iir_Value_I64 => + Dst.I64 := Src.I64; + when Iir_Value_F64 => + Dst.F64 := Src.F64; + end case; + end Iir_Value_To_Value; + + type Read_Signal_Flag_Enum is + (Read_Signal_Event, + Read_Signal_Active, + -- In order to reuse the same code (that returns immediately if the + -- attribute is true), we use not driving. + Read_Signal_Not_Driving); + + function Read_Signal_Flag (Lit: Iir_Value_Literal_Acc; + Kind : Read_Signal_Flag_Enum) + return Boolean + is + begin + case Lit.Kind is + when Iir_Value_Array => + for I in Lit.Val_Array.V'Range loop + if Read_Signal_Flag (Lit.Val_Array.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Record => + for I in Lit.Val_Record.V'Range loop + if Read_Signal_Flag (Lit.Val_Record.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Signal => + case Kind is + when Read_Signal_Event => + return Lit.Sig.Event; + when Read_Signal_Active => + return Lit.Sig.Active; + when Read_Signal_Not_Driving => + if Grt.Signals.Ghdl_Signal_Driving (Lit.Sig) = True then + return False; + else + return True; + end if; + end case; + when others => + raise Internal_Error; + end case; + end Read_Signal_Flag; + + function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Event); + end Execute_Event_Attribute; + + function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Active); + end Execute_Active_Attribute; + + function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return not Read_Signal_Flag (Lit, Read_Signal_Not_Driving); + end Execute_Driving_Attribute; + + function Execute_Read_Signal_Value + (Sig: Iir_Value_Literal_Acc; Attr : Read_Signal_Value_Enum) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr); + end loop; + return Res; + when Iir_Value_Signal => + case Attr is + when Read_Signal_Last_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Last_Value); + when Read_Signal_Driver_Value => + case Sig.Sig.Mode is + when Mode_F64 => + return Create_F64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_F64 + (Sig.Sig)); + when Mode_I64 => + return Create_I64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_I64 + (Sig.Sig)); + when Mode_E32 => + return Create_E32_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_E32 + (Sig.Sig)); + when Mode_B1 => + return Create_B1_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_B1 + (Sig.Sig)); + when others => + raise Internal_Error; + end case; + when Read_Signal_Effective_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Value_Ptr.all); + when Read_Signal_Driving_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Driving_Value); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Value; + + procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Attr : Write_Signal_Enum) is + begin + case Sig.Kind is + when Iir_Value_Array => + pragma Assert (Val.Kind = Iir_Value_Array); + pragma Assert (Sig.Val_Array.Len = Val.Val_Array.Len); + for I in Sig.Val_Array.V'Range loop + Execute_Write_Signal + (Sig.Val_Array.V (I), Val.Val_Array.V (I), Attr); + end loop; + when Iir_Value_Record => + pragma Assert (Val.Kind = Iir_Value_Record); + pragma Assert (Sig.Val_Record.Len = Val.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Execute_Write_Signal + (Sig.Val_Record.V (I), Val.Val_Record.V (I), Attr); + end loop; + when Iir_Value_Signal => + pragma Assert (Val.Kind in Iir_Value_Scalars); + case Attr is + when Write_Signal_Driving_Value => + Iir_Value_To_Value (Val, Sig.Sig.Driving_Value); + when Write_Signal_Effective_Value => + Iir_Value_To_Value (Val, Sig.Sig.Value_Ptr.all); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Write_Signal; + + function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Last_Value); + end Execute_Last_Value_Attribute; + + function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Driver_Value); + end Execute_Driving_Value_Attribute; + + type Signal_Read_Last_Type is + (Read_Last_Event, + Read_Last_Active); + + -- Return the Last_Event absolute time. + function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc; + Kind : Signal_Read_Last_Type) + return Ghdl_I64 + is + Res: Ghdl_I64; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Ghdl_I64'First; + for I in Indirect.Val_Array.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_Record => + Res := Ghdl_I64'First; + for I in Indirect.Val_Record.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Record.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_Signal => + case Kind is + when Read_Last_Event => + return Ghdl_I64 (Indirect.Sig.Last_Event); + when Read_Last_Active => + return Ghdl_I64 (Indirect.Sig.Last_Active); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Last; + + function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Event); + end Execute_Last_Event_Attribute; + + function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Active); + end Execute_Last_Active_Attribute; + + function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Indirect); + for I in Indirect.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Signal_Value (Indirect.Val_Array.V (I)); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Indirect.Val_Record.Len); + for I in Indirect.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Signal_Value (Indirect.Val_Record.V (I)); + end loop; + return Res; + when Iir_Value_Signal => + return Value_To_Iir_Value + (Indirect.Sig.Mode, Indirect.Sig.Value_Ptr.all); + when others => + raise Internal_Error; + end case; + end Execute_Signal_Value; + + procedure Assign_Value_To_Array_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Array.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Array.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Array.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Array_Signal; + + procedure Assign_Value_To_Record_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Record.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Record.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Record.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Record_Signal; + + procedure Assign_Value_To_Scalar_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + pragma Unreferenced (Instance); + use Grt.Signals; + begin + declare + El : Transaction_El_Type renames Transactions.Els (1); + begin + if El.Value = null then + Ghdl_Signal_Start_Assign_Null + (Target.Sig, Transactions.Reject, El.After); + if Transactions.Els'Last /= 1 then + raise Internal_Error; + end if; + return; + end if; + + -- FIXME: null transaction, check constraints. + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Start_Assign_B1 + (Target.Sig, Transactions.Reject, El.Value.B1, El.After); + when Iir_Value_E8 => + Ghdl_Signal_Start_Assign_E8 + (Target.Sig, Transactions.Reject, El.Value.E8, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Start_Assign_E32 + (Target.Sig, Transactions.Reject, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Start_Assign_I64 + (Target.Sig, Transactions.Reject, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Start_Assign_F64 + (Target.Sig, Transactions.Reject, El.Value.F64, El.After); + end case; + end; + + for I in 2 .. Transactions.Els'Last loop + declare + El : Transaction_El_Type renames Transactions.Els (I); + begin + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Next_Assign_B1 + (Target.Sig, El.Value.B1, El.After); + when Iir_Value_E8 => + Ghdl_Signal_Next_Assign_E8 + (Target.Sig, El.Value.E8, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Next_Assign_E32 + (Target.Sig, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Next_Assign_I64 + (Target.Sig, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Next_Assign_F64 + (Target.Sig, El.Value.F64, El.After); + end case; + end; + end loop; + end Assign_Value_To_Scalar_Signal; + + procedure Assign_Value_To_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transaction: Transaction_Type) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Value_To_Array_Signal + (Instance, Target, Transaction); + when Iir_Value_Record => + Assign_Value_To_Record_Signal + (Instance, Target, Transaction); + when Iir_Value_Signal => + Assign_Value_To_Scalar_Signal + (Instance, Target, Transaction); + when Iir_Value_Scalars + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Assign_Value_To_Signal; + + procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Record.V (I)); + end loop; + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Disconnect (Sig.Sig); + when others => + raise Internal_Error; + end case; + end Disconnect_Signal; + + -- Call Ghdl_Process_Wait_Add_Sensitivity for each scalar subelement of + -- SIG. + procedure Wait_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) + is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Wait_Add_Sensitivity; + + -- Return true if the process should be suspended. + function Execute_Wait_Statement (Instance : Block_Instance_Acc; + Stmt: Iir_Wait_Statement) + return Boolean + is + Expr: Iir; + El : Iir; + List: Iir_List; + It : List_Iterator; + Res: Iir_Value_Literal_Acc; + Status : Boolean; + Marker : Mark_Type; + begin + if not Instance.In_Wait_Flag then + Mark (Marker, Expr_Pool); + + -- LRM93 8.1 + -- The execution of a wait statement causes the time expression to + -- be evaluated to determine the timeout interval. + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Grt.Processes.Ghdl_Process_Wait_Set_Timeout + (Std_Time (Res.I64), null, 0); + end if; + + -- LRM93 8.1 + -- The suspended process may also resume as a result of an event + -- occuring on any signal in the sensitivity set of the wait + -- statement. + List := Get_Sensitivity_List (Stmt); + It := List_Iterate_Safe (List); + while Is_Valid (It) loop + El := Get_Element (It); + Wait_Add_Sensitivity (Execute_Name (Instance, El, True)); + Next (It); + end loop; + + -- LRM93 8.1 + -- It also causes the execution of the corresponding process + -- statement to be suspended. + Grt.Processes.Ghdl_Process_Wait_Suspend; + Instance.In_Wait_Flag := True; + Release (Marker, Expr_Pool); + return True; + else + -- LRM93 8.1 + -- The suspended process will resume, at the latest, immediately + -- after the timeout interval has expired. + if not Grt.Processes.Ghdl_Process_Wait_Timed_Out then + -- Compute the condition clause only if the timeout has not + -- expired. + + -- LRM93 8.1 + -- If such an event occurs, the condition in the condition clause + -- is evaluated. + -- + -- if no condition clause appears, the condition clause until true + -- is assumed. + Status := + Execute_Condition (Instance, Get_Condition_Clause (Stmt)); + if not Status then + -- LRM93 8.1 + -- If the value of the condition is FALSE, the process will + -- re-suspend. + -- Such re-suspension does not involve the recalculation of + -- the timeout interval. + Grt.Processes.Ghdl_Process_Wait_Suspend; + return True; + end if; + end if; + + -- LRM93 8.1 + -- If the value of the condition is TRUE, the process will resume. + -- next statement. + Grt.Processes.Ghdl_Process_Wait_Close; + + Instance.In_Wait_Flag := False; + return False; + end if; + end Execute_Wait_Statement; + + type Resolver_Read_Mode is (Read_Port, Read_Driver); + + function Resolver_Read_Value (Sig : Iir_Value_Literal_Acc; + Mode : Resolver_Read_Mode; + Index : Ghdl_Index_Type) + return Iir_Value_Literal_Acc + is + use Grt.Signals; + Val : Ghdl_Value_Ptr; + Res : Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Resolver_Read_Value (Sig.Val_Array.V (I), Mode, Index); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Resolver_Read_Value (Sig.Val_Record.V (I), Mode, Index); + end loop; + when Iir_Value_Signal => + case Mode is + when Read_Port => + Val := Ghdl_Signal_Read_Port (Sig.Sig, Index); + when Read_Driver => + Val := Ghdl_Signal_Read_Driver (Sig.Sig, Index); + end case; + Res := Value_To_Iir_Value (Sig.Sig.Mode, Val.all); + when others => + raise Internal_Error; + end case; + return Res; + end Resolver_Read_Value; + + procedure Resolution_Proc (Instance_Addr : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type) + is + pragma Unreferenced (Val); + + Instance : Resolv_Instance_Type; + pragma Import (Ada, Instance); + for Instance'Address use Instance_Addr; + + type Bool_Array is array (1 .. Nbr_Drv) of Boolean; + Vec : Bool_Array; + pragma Import (Ada, Vec); + for Vec'Address use Bool_Vec; + Off : Iir_Index32; + + Arr : Iir_Value_Literal_Acc; + Arr_Type : constant Iir := + Get_Type (Get_Interface_Declaration_Chain (Instance.Func)); + + Res : Iir_Value_Literal_Acc; + + Len : constant Iir_Index32 := Iir_Index32 (Vec_Len + Nbr_Ports); + Instance_Mark, Expr_Mark : Mark_Type; + begin + pragma Assert (Instance_Pool = null); + Instance_Pool := Global_Pool'Access; + Mark (Instance_Mark, Instance_Pool.all); + Mark (Expr_Mark, Expr_Pool); + Current_Process := No_Process; + + Arr := Create_Array_Value (Len, 1); + Arr.Bounds.D (1) := Create_Bounds_From_Length + (Instance.Block, + Get_Nth_Element (Get_Index_Subtype_List (Arr_Type), 0), + Len); + + -- First ports + for I in 1 .. Nbr_Ports loop + Arr.Val_Array.V (Iir_Index32 (I)) := Resolver_Read_Value + (Instance.Sig, Read_Port, I - 1); + end loop; + + -- Then drivers. + Off := Iir_Index32 (Nbr_Ports) + 1; + for I in 1 .. Nbr_Drv loop + if Vec (I) then + Arr.Val_Array.V (Off) := Resolver_Read_Value + (Instance.Sig, Read_Driver, I - 1); + Off := Off + 1; + end if; + end loop; + + -- Call resolution function. + Res := Execute_Resolution_Function (Instance.Block, Instance.Func, Arr); + + -- Set driving value. + Execute_Write_Signal (Instance.Sig, Res, Write_Signal_Driving_Value); + + Release (Instance_Mark, Instance_Pool.all); + Release (Expr_Mark, Expr_Pool); + Instance_Pool := null; + end Resolution_Proc; + + function Guard_Func (Data : System.Address) return Ghdl_B1 + is + Guard : Guard_Instance_Type; + pragma Import (Ada, Guard); + for Guard'Address use Data; + + Val : Boolean; + + Prev_Instance_Pool : Areapool_Acc; + begin + pragma Assert (Instance_Pool = null + or else Instance_Pool = Global_Pool'Access); + Prev_Instance_Pool := Instance_Pool; + + Instance_Pool := Global_Pool'Access; + Current_Process := No_Process; + + Val := Execute_Condition + (Guard.Instance, Get_Guard_Expression (Guard.Guard)); + + Instance_Pool := Prev_Instance_Pool; + + return Ghdl_B1'Val (Boolean'Pos (Val)); + end Guard_Func; +end Simul.Simulation; |