-- Statements synthesis. -- Copyright (C) 2017 Tristan Gingold -- -- This file is part of GHDL. -- -- This program 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 of the License, or -- (at your option) any later version. -- -- This program 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 this program. If not, see . with Ada.Unchecked_Deallocation; with Grt.Types; use Grt.Types; with Grt.Algos; with Grt.Severity; use Grt.Severity; with Areapools; with Name_Table; with Std_Names; with Errorout; use Errorout; with Files_Map; with Simple_IO; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Sem_Expr; with Vhdl.Sem_Inst; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Std_Package; with Vhdl.Evaluation; with Vhdl.Ieee.Std_Logic_1164; with PSL.Types; with PSL.NFAs; with Synth.Errors; use Synth.Errors; with Synth.Decls; use Synth.Decls; with Synth.Expr; use Synth.Expr; with Synth.Insts; use Synth.Insts; with Synth.Source; with Synth.Static_Proc; with Synth.Heap; with Synth.Flags; with Synth.Debugger; with Netlists.Builders; use Netlists.Builders; with Netlists.Folds; use Netlists.Folds; with Netlists.Gates; use Netlists.Gates; with Netlists.Utils; use Netlists.Utils; with Netlists.Locations; use Netlists.Locations; package body Synth.Stmts is procedure Synth_Sequential_Statements (C : in out Seq_Context; Stmts : Node); procedure Set_Location (N : Net; Loc : Node) renames Synth.Source.Set_Location; function Synth_Waveform (Syn_Inst : Synth_Instance_Acc; Wf : Node; Targ_Type : Type_Acc) return Valtyp is Res : Valtyp; begin if Get_Kind (Wf) = Iir_Kind_Unaffected_Waveform then -- TODO raise Internal_Error; end if; if Get_Chain (Wf) /= Null_Node then -- Warning. null; end if; if Get_Time (Wf) /= Null_Node then -- Warning null; end if; if Targ_Type = null then return Synth_Expression (Syn_Inst, Get_We_Value (Wf)); else Res := Synth_Expression_With_Type (Syn_Inst, Get_We_Value (Wf), Targ_Type); Res := Synth_Subtype_Conversion (Get_Build (Syn_Inst), Res, Targ_Type, False, Wf); return Res; end if; end Synth_Waveform; procedure Synth_Assignment_Prefix (Syn_Inst : Synth_Instance_Acc; Pfx : Node; Dest_Base : out Valtyp; Dest_Typ : out Type_Acc; Dest_Off : out Value_Offsets; Dest_Dyn : out Dyn_Name) is begin case Get_Kind (Pfx) is when Iir_Kind_Simple_Name => Synth_Assignment_Prefix (Syn_Inst, Get_Named_Entity (Pfx), Dest_Base, Dest_Typ, Dest_Off, Dest_Dyn); when Iir_Kind_Interface_Signal_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Signal_Declaration | Iir_Kind_Anonymous_Signal_Declaration | Iir_Kind_Interface_Constant_Declaration | Iir_Kind_Constant_Declaration | Iir_Kind_File_Declaration | Iir_Kind_Interface_File_Declaration | Iir_Kind_Object_Alias_Declaration => declare Targ : constant Valtyp := Get_Value (Syn_Inst, Pfx); begin Dest_Dyn := No_Dyn_Name; Dest_Typ := Targ.Typ; if Targ.Val.Kind = Value_Alias then -- Replace alias by the aliased name. Dest_Base := (Targ.Val.A_Typ, Targ.Val.A_Obj); Dest_Off := Targ.Val.A_Off; else Dest_Base := Targ; Dest_Off := (0, 0); end if; end; when Iir_Kind_Function_Call => Dest_Base := Synth_Expression (Syn_Inst, Pfx); Dest_Typ := Dest_Base.Typ; Dest_Off := (0, 0); Dest_Dyn := No_Dyn_Name; when Iir_Kind_Indexed_Name => declare Voff : Net; Off : Value_Offsets; begin Synth_Assignment_Prefix (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off, Dest_Dyn); Strip_Const (Dest_Base); Synth_Indexed_Name (Syn_Inst, Pfx, Dest_Typ, Voff, Off); if Voff = No_Net then -- Static index. Dest_Off := Dest_Off + Off; else -- Dynamic index. if Dest_Dyn.Voff = No_Net then -- The first one. Dest_Dyn := (Pfx_Off => Dest_Off, Pfx_Typ => Dest_Typ, Voff => Voff); Dest_Off := Off; else -- Nested one. -- FIXME Dest_Off := Dest_Off + Off; -- if Dest_Off /= (0, 0) then -- Error_Msg_Synth (+Pfx, "nested memory not supported"); -- end if; Dest_Dyn.Voff := Build_Addidx (Get_Build (Syn_Inst), Dest_Dyn.Voff, Voff); end if; end if; Dest_Typ := Get_Array_Element (Dest_Typ); end; when Iir_Kind_Selected_Element => declare Idx : constant Iir_Index32 := Get_Element_Position (Get_Named_Entity (Pfx)); begin Synth_Assignment_Prefix (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off, Dest_Dyn); Dest_Off.Net_Off := Dest_Off.Net_Off + Dest_Typ.Rec.E (Idx + 1).Boff; Dest_Off.Mem_Off := Dest_Off.Mem_Off + Dest_Typ.Rec.E (Idx + 1).Moff; Dest_Typ := Dest_Typ.Rec.E (Idx + 1).Typ; end; when Iir_Kind_Slice_Name => declare Pfx_Bnd : Bound_Type; El_Typ : Type_Acc; Res_Bnd : Bound_Type; Sl_Voff : Net; Sl_Off : Value_Offsets; begin Synth_Assignment_Prefix (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off, Dest_Dyn); Strip_Const (Dest_Base); Get_Onedimensional_Array_Bounds (Dest_Typ, Pfx_Bnd, El_Typ); Synth_Slice_Suffix (Syn_Inst, Pfx, Pfx_Bnd, El_Typ, Res_Bnd, Sl_Voff, Sl_Off); if Sl_Voff = No_Net then -- Fixed slice. Dest_Typ := Create_Onedimensional_Array_Subtype (Dest_Typ, Res_Bnd); Dest_Off.Net_Off := Dest_Off.Net_Off + Sl_Off.Net_Off; Dest_Off.Mem_Off := Dest_Off.Mem_Off + Sl_Off.Mem_Off; else -- Variable slice. if Dest_Dyn.Voff = No_Net then -- First one. Dest_Dyn := (Pfx_Off => Dest_Off, Pfx_Typ => Dest_Typ, Voff => Sl_Voff); Dest_Off := Sl_Off; else -- Nested. if Dest_Off /= (0, 0) then Error_Msg_Synth (+Pfx, "nested memory not supported"); end if; Dest_Dyn.Voff := Build_Addidx (Get_Build (Syn_Inst), Dest_Dyn.Voff, Sl_Voff); end if; Dest_Typ := Create_Slice_Type (Res_Bnd.Len, El_Typ); end if; end; when Iir_Kind_Implicit_Dereference | Iir_Kind_Dereference => Synth_Assignment_Prefix (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off, Dest_Dyn); if Dest_Off /= (0, 0) and then Dest_Dyn.Voff /= No_Net then raise Internal_Error; end if; Dest_Base := Heap.Synth_Dereference (Read_Access (Dest_Base)); Dest_Typ := Dest_Base.Typ; when others => Error_Kind ("synth_assignment_prefix", Pfx); end case; end Synth_Assignment_Prefix; type Target_Kind is ( -- The target is an object or a static part of it. Target_Simple, -- The target is an aggregate. Target_Aggregate, -- The assignment is dynamically indexed. Target_Memory ); type Target_Info (Kind : Target_Kind := Target_Simple) is record -- In all cases, the type of the target is known or computed. Targ_Type : Type_Acc; case Kind is when Target_Simple => -- For a simple target, the destination is known. Obj : Valtyp; Off : Value_Offsets; when Target_Aggregate => -- For an aggregate: the type is computed and the details will -- be handled at the assignment. Aggr : Node; when Target_Memory => -- For a memory: the destination is known. Mem_Obj : Valtyp; -- The dynamic offset. Mem_Dyn : Dyn_Name; -- Offset of the data to be accessed from the memory. Mem_Doff : Uns32; end case; end record; type Target_Info_Array is array (Natural range <>) of Target_Info; function Synth_Aggregate_Target_Type (Syn_Inst : Synth_Instance_Acc; Target : Node) return Type_Acc is Targ_Type : constant Node := Get_Type (Target); Base_Type : constant Node := Get_Base_Type (Targ_Type); Base_Typ : Type_Acc; Bnd : Bound_Type; Len : Uns32; Res : Type_Acc; begin Base_Typ := Get_Subtype_Object (Syn_Inst, Base_Type); -- It's a basetype, so not bounded. pragma Assert (Base_Typ.Kind = Type_Unbounded_Vector); if Is_Fully_Constrained_Type (Targ_Type) then -- If the aggregate subtype is known, just use it. Bnd := Expr.Synth_Array_Bounds (Syn_Inst, Targ_Type, 1); else -- Ok, so the subtype of the aggregate is not known, in general -- because the length of an element is not known. That's with -- vhdl-2008. Len := 0; declare Choice : Node; El : Node; El_Typ : Type_Acc; begin Choice := Get_Association_Choices_Chain (Target); while Choice /= Null_Node loop pragma Assert (Get_Kind (Choice) = Iir_Kind_Choice_By_None); El := Get_Associated_Expr (Choice); El_Typ := Synth_Type_Of_Object (Syn_Inst, El); Bnd := Get_Array_Bound (El_Typ, 1); Len := Len + Bnd.Len; Choice := Get_Chain (Choice); end loop; end; -- Compute the range. declare Idx_Type : constant Node := Get_Index_Type (Base_Type, 0); Idx_Typ : Type_Acc; begin Idx_Typ := Get_Subtype_Object (Syn_Inst, Idx_Type); Bnd := (Dir => Idx_Typ.Drange.Dir, Left => Int32 (Idx_Typ.Drange.Left), Right => 0, Len => Len); case Bnd.Dir is when Dir_To => Bnd.Right := Bnd.Left + Int32 (Len); when Dir_Downto => Bnd.Right := Bnd.Left - Int32 (Len); end case; end; end if; -- Compute the type. case Base_Typ.Kind is when Type_Unbounded_Vector => Res := Create_Vector_Type (Bnd, Base_Typ.Uvec_El); when others => raise Internal_Error; end case; return Res; end Synth_Aggregate_Target_Type; function Synth_Target (Syn_Inst : Synth_Instance_Acc; Target : Node) return Target_Info is begin case Get_Kind (Target) is when Iir_Kind_Aggregate => return Target_Info'(Kind => Target_Aggregate, Targ_Type => Synth_Aggregate_Target_Type (Syn_Inst, Target), Aggr => Target); when Iir_Kind_Simple_Name | Iir_Kind_Selected_Element | Iir_Kind_Interface_Signal_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Signal_Declaration | Iir_Kind_Anonymous_Signal_Declaration | Iir_Kind_Indexed_Name | Iir_Kind_Slice_Name | Iir_Kind_Dereference => declare Base : Valtyp; Typ : Type_Acc; Off : Value_Offsets; Dyn : Dyn_Name; begin Synth_Assignment_Prefix (Syn_Inst, Target, Base, Typ, Off, Dyn); if Dyn.Voff = No_Net then -- FIXME: check index. return Target_Info'(Kind => Target_Simple, Targ_Type => Typ, Obj => Base, Off => Off); else return Target_Info'(Kind => Target_Memory, Targ_Type => Typ, Mem_Obj => Base, Mem_Dyn => Dyn, Mem_Doff => Off.Net_Off); end if; end; when others => Error_Kind ("synth_target", Target); end case; end Synth_Target; procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc; Target : Target_Info; Val : Valtyp; Loc : Node); -- Extract a part of VAL from a target aggregate at offset OFF (offset -- in the array). function Aggregate_Extract (Ctxt : Context_Acc; Val : Valtyp; Off : Uns32; Typ : Type_Acc; Loc : Node) return Valtyp is El_Typ : constant Type_Acc := Get_Array_Element (Val.Typ); begin case Val.Val.Kind is when Value_Net | Value_Wire => declare N : Net; begin N := Build2_Extract (Ctxt, Get_Net (Ctxt, Val), Off * El_Typ.W, Typ.W); Set_Location (N, Loc); return Create_Value_Net (N, Typ); end; when Value_Memory => declare Res : Valtyp; begin Res := Create_Value_Memory (Typ); -- Need to reverse offsets. Copy_Memory (Res.Val.Mem, Val.Val.Mem + (Val.Typ.Sz - Size_Type (Off + 1) * El_Typ.Sz), Typ.Sz); return Res; end; when others => raise Internal_Error; end case; end Aggregate_Extract; procedure Synth_Assignment_Aggregate (Syn_Inst : Synth_Instance_Acc; Target : Node; Target_Typ : Type_Acc; Val : Valtyp; Loc : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Targ_Bnd : constant Bound_Type := Get_Array_Bound (Target_Typ, 1); Choice : Node; Assoc : Node; Pos : Uns32; Targ_Info : Target_Info; begin Choice := Get_Association_Choices_Chain (Target); Pos := Targ_Bnd.Len; while Is_Valid (Choice) loop Assoc := Get_Associated_Expr (Choice); case Get_Kind (Choice) is when Iir_Kind_Choice_By_None => Targ_Info := Synth_Target (Syn_Inst, Assoc); if Get_Element_Type_Flag (Choice) then Pos := Pos - 1; else Pos := Pos - Get_Array_Bound (Targ_Info.Targ_Type, 1).Len; end if; Synth_Assignment (Syn_Inst, Targ_Info, Aggregate_Extract (Ctxt, Val, Pos, Targ_Info.Targ_Type, Assoc), Loc); when others => Error_Kind ("synth_assignment_aggregate", Choice); end case; Choice := Get_Chain (Choice); end loop; end Synth_Assignment_Aggregate; procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc; Target : Target_Info; Val : Valtyp; Loc : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); V : Valtyp; begin V := Synth_Subtype_Conversion (Ctxt, Val, Target.Targ_Type, False, Loc); pragma Unreferenced (Val); if V = No_Valtyp then -- In case of error. return; end if; case Target.Kind is when Target_Aggregate => Synth_Assignment_Aggregate (Syn_Inst, Target.Aggr, Target.Targ_Type, V, Loc); when Target_Simple => if V.Typ.Sz = 0 then -- If there is nothing to assign (like a null slice), -- return now. return; end if; if Target.Obj.Val.Kind = Value_Wire then if Is_Static (V.Val) and then V.Typ.Sz = Target.Obj.Typ.Sz then pragma Assert (Target.Off = (0, 0)); Phi_Assign_Static (Target.Obj.Val.W, Unshare (Get_Memtyp (V))); else if V.Typ.W = 0 then -- Forget about null wires. return; end if; Phi_Assign_Net (Ctxt, Target.Obj.Val.W, Get_Net (Ctxt, V), Target.Off.Net_Off); end if; else if not Is_Static (V.Val) then -- Maybe the error message is too cryptic ? Error_Msg_Synth (+Loc, "cannot assign a net to a static value"); else Strip_Const (V); Copy_Memory (Target.Obj.Val.Mem + Target.Off.Mem_Off, V.Val.Mem, V.Typ.Sz); end if; end if; when Target_Memory => declare Ctxt : constant Context_Acc := Get_Build (Syn_Inst); N : Net; begin N := Get_Current_Assign_Value (Ctxt, Target.Mem_Obj.Val.W, Target.Mem_Dyn.Pfx_Off.Net_Off, Target.Mem_Dyn.Pfx_Typ.W); N := Build_Dyn_Insert (Ctxt, N, Get_Net (Ctxt, V), Target.Mem_Dyn.Voff, Target.Mem_Doff); Set_Location (N, Loc); Phi_Assign_Net (Ctxt, Target.Mem_Obj.Val.W, N, Target.Mem_Dyn.Pfx_Off.Net_Off); end; end case; end Synth_Assignment; procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc; Target : Node; Val : Valtyp; Loc : Node) is Info : Target_Info; begin Info := Synth_Target (Syn_Inst, Target); Synth_Assignment (Syn_Inst, Info, Val, Loc); end Synth_Assignment; function Synth_Read_Memory (Syn_Inst : Synth_Instance_Acc; Obj : Valtyp; Res_Typ : Type_Acc; Off : Uns32; Dyn : Dyn_Name; Loc : Node) return Valtyp is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); N : Net; begin N := Get_Net (Ctxt, Obj); if Dyn.Voff /= No_Net then Synth.Source.Set_Location_Maybe (N, Loc); if Dyn.Pfx_Off.Net_Off /= 0 then N := Build2_Extract (Ctxt, N, Dyn.Pfx_Off.Net_Off, Dyn.Pfx_Typ.W); end if; if Res_Typ.W /= 0 then -- Do not try to extract if the net is null. N := Build_Dyn_Extract (Ctxt, N, Dyn.Voff, Off, Res_Typ.W); end if; else pragma Assert (not Is_Static (Obj.Val)); N := Build2_Extract (Ctxt, N, Off, Res_Typ.W); end if; Set_Location (N, Loc); return Create_Value_Net (N, Res_Typ); end Synth_Read_Memory; function Synth_Read (Syn_Inst : Synth_Instance_Acc; Targ : Target_Info; Loc : Node) return Valtyp is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); N : Net; begin case Targ.Kind is when Target_Simple => N := Build2_Extract (Ctxt, Get_Net (Ctxt, Targ.Obj), Targ.Off.Net_Off, Targ.Targ_Type.W); return Create_Value_Net (N, Targ.Targ_Type); when Target_Aggregate => raise Internal_Error; when Target_Memory => return Synth_Read_Memory (Syn_Inst, Targ.Mem_Obj, Targ.Targ_Type, 0, Targ.Mem_Dyn, Loc); end case; end Synth_Read; -- Concurrent or sequential simple signal assignment procedure Synth_Simple_Signal_Assignment (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Targ : Target_Info; Val : Valtyp; begin Targ := Synth_Target (Syn_Inst, Get_Target (Stmt)); Val := Synth_Waveform (Syn_Inst, Get_Waveform_Chain (Stmt), Targ.Targ_Type); Synth_Assignment (Syn_Inst, Targ, Val, Stmt); end Synth_Simple_Signal_Assignment; procedure Synth_Conditional_Signal_Assignment (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Targ : Target_Info; Cond : Node; Cwf : Node; Inp : Input; Val, Cond_Val : Valtyp; Cond_Net : Net; First, Last : Net; V : Net; begin Targ := Synth_Target (Syn_Inst, Get_Target (Stmt)); Last := No_Net; Cwf := Get_Conditional_Waveform_Chain (Stmt); Cond := Null_Node; while Cwf /= Null_Node loop Val := Synth_Waveform (Syn_Inst, Get_Waveform_Chain (Cwf), Targ.Targ_Type); if Val = No_Valtyp then -- Mark the error, but try to continue. Set_Error (Syn_Inst); else V := Get_Net (Ctxt, Val); Cond := Get_Condition (Cwf); if Cond /= Null_Node then Cond_Val := Synth_Expression (Syn_Inst, Cond); if Cond_Val = No_Valtyp then Cond_Net := Build_Const_UB32 (Ctxt, 0, 1); else Cond_Net := Get_Net (Ctxt, Cond_Val); end if; V := Build_Mux2 (Ctxt, Cond_Net, No_Net, V); Set_Location (V, Cwf); end if; if Last /= No_Net then Inp := Get_Input (Get_Net_Parent (Last), 1); Connect (Inp, V); else First := V; end if; Last := V; end if; Cwf := Get_Chain (Cwf); end loop; if Cond /= Null_Node then pragma Assert (Last /= No_Net); Inp := Get_Input (Get_Net_Parent (Last), 1); if Get_Driver (Inp) = No_Net then -- No else. Val := Synth_Read (Syn_Inst, Targ, Stmt); Connect (Inp, Get_Net (Ctxt, Val)); end if; end if; Val := Create_Value_Net (First, Targ.Targ_Type); Synth_Assignment (Syn_Inst, Targ, Val, Stmt); end Synth_Conditional_Signal_Assignment; procedure Synth_Variable_Assignment (C : Seq_Context; Stmt : Node) is Targ : Target_Info; Val : Valtyp; begin Targ := Synth_Target (C.Inst, Get_Target (Stmt)); Val := Synth_Expression_With_Type (C.Inst, Get_Expression (Stmt), Targ.Targ_Type); if Val = No_Valtyp then Set_Error (C.Inst); return; end if; Synth_Assignment (C.Inst, Targ, Val, Stmt); end Synth_Variable_Assignment; procedure Synth_Conditional_Variable_Assignment (C : Seq_Context; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (C.Inst); Target : constant Node := Get_Target (Stmt); Targ_Type : Type_Acc; Cond : Node; Ce : Node; Val, Cond_Val : Valtyp; V : Net; First, Last : Net; begin Targ_Type := Get_Subtype_Object (C.Inst, Get_Type (Target)); Last := No_Net; Ce := Get_Conditional_Expression_Chain (Stmt); while Ce /= Null_Node loop Val := Synth_Expression_With_Type (C.Inst, Get_Expression (Ce), Targ_Type); V := Get_Net (Ctxt, Val); Cond := Get_Condition (Ce); if Cond /= Null_Node then Cond_Val := Synth_Expression (C.Inst, Cond); V := Build_Mux2 (Ctxt, Get_Net (Ctxt, Cond_Val), No_Net, V); Set_Location (V, Ce); end if; if Last /= No_Net then Connect (Get_Input (Get_Net_Parent (Last), 1), V); else First := V; end if; Last := V; Ce := Get_Chain (Ce); end loop; Val := Create_Value_Net (First, Targ_Type); Synth_Assignment (C.Inst, Target, Val, Stmt); end Synth_Conditional_Variable_Assignment; procedure Synth_If_Statement (C : in out Seq_Context; Stmt : Node) is Cond : constant Node := Get_Condition (Stmt); Els : constant Node := Get_Else_Clause (Stmt); Ctxt : constant Context_Acc := Get_Build (C.Inst); Cond_Val : Valtyp; Cond_Net : Net; Phi_True : Phi_Type; Phi_False : Phi_Type; begin Cond_Val := Synth_Expression (C.Inst, Cond); if Cond_Val = No_Valtyp then Set_Error (C.Inst); return; end if; if Is_Static_Val (Cond_Val.Val) then Strip_Const (Cond_Val); if Read_Discrete (Get_Value_Memtyp (Cond_Val)) = 1 then -- True. Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Stmt)); else pragma Assert (Read_Discrete (Get_Value_Memtyp (Cond_Val)) = 0); if Is_Valid (Els) then -- Else part if Is_Null (Get_Condition (Els)) then -- Final else part. Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Els)); else -- Elsif. Handled as a nested if. Synth_If_Statement (C, Els); end if; end if; end if; else -- The statements for the 'then' part. Push_Phi; Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Stmt)); Pop_Phi (Phi_True); Push_Phi; if Is_Valid (Els) then if Is_Null (Get_Condition (Els)) then -- Final else part. Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Els)); else -- Elsif. Handled as a nested if. Synth_If_Statement (C, Els); end if; end if; Pop_Phi (Phi_False); Cond_Net := Get_Net (Ctxt, Cond_Val); Merge_Phis (Ctxt, Cond_Net, Phi_True, Phi_False, Stmt); end if; end Synth_If_Statement; type Alternative_Index is new Int32; -- Only keep '0' and '1' in choices for std_logic. function Ignore_Choice_Logic (V : Ghdl_U8; Loc : Node) return Boolean is begin case V is when Vhdl.Ieee.Std_Logic_1164.Std_Logic_0_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_1_Pos => return False; when Vhdl.Ieee.Std_Logic_1164.Std_Logic_L_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_H_Pos => Warning_Msg_Synth (+Loc, "choice with 'L' or 'H' value is ignored"); return True; when Vhdl.Ieee.Std_Logic_1164.Std_Logic_U_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_X_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_D_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_Z_Pos | Vhdl.Ieee.Std_Logic_1164.Std_Logic_W_Pos => Warning_Msg_Synth (+Loc, "choice with meta-value is ignored"); return True; when others => -- Only 9 values. raise Internal_Error; end case; end Ignore_Choice_Logic; function Ignore_Choice_Expression (V : Valtyp; Loc : Node) return Boolean is begin case V.Typ.Kind is when Type_Bit => return False; when Type_Logic => if V.Typ = Logic_Type then return Ignore_Choice_Logic (Read_U8 (V.Val.Mem), Loc); else return False; end if; when Type_Discrete => return False; when Type_Vector => if V.Typ.Vec_El = Logic_Type then for I in 1 .. Size_Type (V.Typ.Vbound.Len) loop if Ignore_Choice_Logic (Read_U8 (V.Val.Mem + (I - 1)), Loc) then return True; end if; end loop; return False; else return False; end if; when Type_Array => return False; when others => raise Internal_Error; end case; end Ignore_Choice_Expression; -- Create the condition for choices of CHOICE chain belonging to the same -- alternative. Update CHOICE to the next alternative. procedure Synth_Choice (Syn_Inst : Synth_Instance_Acc; Sel : Net; Choice_Typ : Type_Acc; Nets : in out Net_Array; Other_Choice : in out Nat32; Choice_Idx : in out Nat32; Choice : in out Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Cond : Net; Res : Net; begin Res := No_Net; loop case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is when Iir_Kind_Choice_By_Expression => declare V : Valtyp; begin V := Synth_Expression_With_Basetype (Syn_Inst, Get_Choice_Expression (Choice)); V := Synth_Subtype_Conversion (Ctxt, V, Choice_Typ, False, Choice); if Ignore_Choice_Expression (V, Choice) then Cond := No_Net; else Cond := Build_Compare (Ctxt, Id_Eq, Sel, Get_Net (Ctxt, V)); Set_Location (Cond, Choice); end if; end; when Iir_Kind_Choice_By_Range => declare Rng : Discrete_Range_Type; Cmp_L, Cmp_R : Module_Id; L, R : Net; begin Synth_Discrete_Range (Syn_Inst, Get_Choice_Range (Choice), Rng); if Rng.Is_Signed then case Rng.Dir is when Dir_To => Cmp_L := Id_Sge; Cmp_R := Id_Sle; when Dir_Downto => Cmp_L := Id_Sle; Cmp_R := Id_Sge; end case; L := Build2_Const_Int (Ctxt, Rng.Left, Choice_Typ.W); R := Build2_Const_Int (Ctxt, Rng.Right, Choice_Typ.W); else case Rng.Dir is when Dir_To => Cmp_L := Id_Uge; Cmp_R := Id_Ule; when Dir_Downto => Cmp_L := Id_Ule; Cmp_R := Id_Uge; end case; L := Build2_Const_Uns (Ctxt, Uns64 (Rng.Left), Choice_Typ.W); R := Build2_Const_Uns (Ctxt, Uns64 (Rng.Right), Choice_Typ.W); end if; L := Build_Compare (Ctxt, Cmp_L, Sel, L); Set_Location (L, Choice); R := Build_Compare (Ctxt, Cmp_R, Sel, R); Set_Location (R, Choice); Cond := Build_Dyadic (Ctxt, Id_And, L, R); Set_Location (Cond, Choice); end; when Iir_Kind_Choice_By_Others => -- Last and only one. pragma Assert (Res = No_Net); Other_Choice := Choice_Idx + 1; pragma Assert (Get_Chain (Choice) = Null_Node); Choice := Null_Node; return; end case; if not Get_Same_Alternative_Flag (Choice) then -- First choice. Choice_Idx := Choice_Idx + 1; Res := Cond; else if Cond = No_Net then -- No new condition. null; else if Res /= No_Net then Res := Build_Dyadic (Ctxt, Id_Or, Res, Cond); Set_Location (Res, Choice); else Res := Cond; end if; end if; end if; Choice := Get_Chain (Choice); exit when Choice = Null_Node or else not Get_Same_Alternative_Flag (Choice); end loop; if Res = No_Net then Res := Build_Const_UB32 (Ctxt, 0, 1); end if; Nets (Choice_Idx) := Res; end Synth_Choice; type Alternative_Data_Type is record Asgns : Seq_Assign; Val : Net; end record; type Alternative_Data_Array is array (Alternative_Index range <>) of Alternative_Data_Type; type Alternative_Data_Acc is access Alternative_Data_Array; procedure Free_Alternative_Data_Array is new Ada.Unchecked_Deallocation (Alternative_Data_Array, Alternative_Data_Acc); type Wire_Id_Array is array (Natural range <>) of Wire_Id; type Wire_Id_Array_Acc is access Wire_Id_Array; procedure Free_Wire_Id_Array is new Ada.Unchecked_Deallocation (Wire_Id_Array, Wire_Id_Array_Acc); procedure Sort_Wire_Id_Array (Arr : in out Wire_Id_Array) is function Lt (Op1, Op2 : Natural) return Boolean is begin return Is_Lt (Arr (Op1), Arr (Op2)); end Lt; procedure Swap (From : Natural; To : Natural) is T : Wire_Id; begin T := Arr (From); Arr (From) := Arr (To); Arr (To) := T; end Swap; procedure Wid_Heap_Sort is new Grt.Algos.Heap_Sort (Lt => Lt, Swap => Swap); begin Wid_Heap_Sort (Arr'Length); end Sort_Wire_Id_Array; -- Count the number of wires used in all the alternatives. function Count_Wires_In_Alternatives (Alts : Alternative_Data_Array) return Natural is Res : Natural; Asgn : Seq_Assign; W : Wire_Id; begin Res := 0; for I in Alts'Range loop Asgn := Alts (I).Asgns; while Asgn /= No_Seq_Assign loop W := Get_Wire_Id (Asgn); if not Get_Wire_Mark (W) then Res := Res + 1; Set_Wire_Mark (W, True); end if; Asgn := Get_Assign_Chain (Asgn); end loop; end loop; return Res; end Count_Wires_In_Alternatives; -- Fill ARR from wire_id of ALTS. procedure Fill_Wire_Id_Array (Arr : out Wire_Id_Array; Alts : Alternative_Data_Array) is Idx : Natural; Asgn : Seq_Assign; W : Wire_Id; begin Idx := Arr'First; for I in Alts'Range loop Asgn := Alts (I).Asgns; while Asgn /= No_Seq_Assign loop W := Get_Wire_Id (Asgn); if Get_Wire_Mark (W) then Arr (Idx) := W; Idx := Idx + 1; Set_Wire_Mark (W, False); end if; Asgn := Get_Assign_Chain (Asgn); end loop; end loop; pragma Assert (Idx = Arr'Last + 1); end Fill_Wire_Id_Array; type Seq_Assign_Value_Array_Acc is access Seq_Assign_Value_Array; procedure Free_Seq_Assign_Value_Array is new Ada.Unchecked_Deallocation (Seq_Assign_Value_Array, Seq_Assign_Value_Array_Acc); procedure Synth_Case_Statement_Dynamic (C : in out Seq_Context; Stmt : Node; Sel : Valtyp) is use Vhdl.Sem_Expr; Ctxt : constant Context_Acc := Get_Build (C.Inst); Choices : constant Node := Get_Case_Statement_Alternative_Chain (Stmt); Case_Info : Choice_Info_Type; -- Array of alternatives Alts : Alternative_Data_Acc; Alt_Idx : Alternative_Index; Others_Alt_Idx : Alternative_Index; Nbr_Choices : Nat32; Pasgns : Seq_Assign_Value_Array_Acc; Nets : Net_Array_Acc; Nbr_Wires : Natural; Wires : Wire_Id_Array_Acc; Sel_Net : Net; begin -- Strategies to synthesize a case statement. Assume the selector is -- a net of W bits -- - a large mux, with 2**W inputs -- - if the number of choices is dense -- - if W is small -- - a onehot mux. Each choice is converted to an single bit condition -- by adding a comparison operator (equal for single choice, -- inequalities for ranges, or for multiple choices). Only one of -- these conditions is true (plus 'others'). -- - if the number of choices is sparse -- - large range choices -- - a tree of mux/mux2 -- - large number of choices, densily grouped but sparsed compared -- to 2**W (eg: a partially filled memory) -- - divide and conquier -- Count choices and alternatives. Count_Choices (Case_Info, Choices); --Fill_Choices_Array (Case_Info, Choices); -- Allocate structures. -- Because there is no 1-1 link between choices and alternatives, -- create an array for the choices and an array for the alternatives. Alts := new Alternative_Data_Array (1 .. Alternative_Index (Case_Info.Nbr_Alternatives)); -- Compute number of non-default alternatives. Nbr_Choices := Nat32 (Case_Info.Nbr_Alternatives); if Case_Info.Others_Choice /= Null_Node then Nbr_Choices := Nbr_Choices - 1; end if; Nets := new Net_Array (1 .. Int32 (Alts'Last)); Sel_Net := Get_Net (Ctxt, Sel); -- Synth statements and keep list of assignments. -- Also synth choices. declare Choice : Node; Choice_Idx, Other_Choice : Nat32; Phi : Phi_Type; begin Alt_Idx := 0; Choice_Idx := 0; Other_Choice := 0; Choice := Choices; while Is_Valid (Choice) loop -- Must be a choice for a new alternative. pragma Assert (not Get_Same_Alternative_Flag (Choice)); -- A new sequence of statements. Alt_Idx := Alt_Idx + 1; Push_Phi; Synth_Sequential_Statements (C, Get_Associated_Chain (Choice)); Pop_Phi (Phi); Alts (Alt_Idx).Asgns := Sort_Phi (Phi); Synth_Choice (C.Inst, Sel_Net, Sel.Typ, Nets.all, Other_Choice, Choice_Idx, Choice); end loop; pragma Assert (Choice_Idx = Nbr_Choices); Others_Alt_Idx := Alternative_Index (Other_Choice); end; -- Create the one-hot vector. if Nbr_Choices = 0 then Sel_Net := No_Net; else Sel_Net := Build2_Concat (Ctxt, Nets (1 .. Nbr_Choices)); end if; -- Create list of wire_id, sort it. Nbr_Wires := Count_Wires_In_Alternatives (Alts.all); Wires := new Wire_Id_Array (1 .. Nbr_Wires); Fill_Wire_Id_Array (Wires.all, Alts.all); Sort_Wire_Id_Array (Wires.all); -- Associate each choice with the assign node -- For each wire_id: -- Build mux2/mux4 tree (group by 4) Pasgns := new Seq_Assign_Value_Array (1 .. Int32 (Alts'Last)); -- For each wire, compute the result. for I in Wires'Range loop declare Wi : constant Wire_Id := Wires (I); Last_Val : Net; Res_Inst : Instance; Res : Net; Default : Net; Min_Off, Off : Uns32; Wd : Width; List : Partial_Assign_List; Sval : Memtyp; begin -- Extract the value for each branch. for I in Alts'Range loop -- If there is an assignment to Wi in Alt, it will define the -- value. if Get_Wire_Id (Alts (I).Asgns) = Wi then Pasgns (Int32 (I)) := Get_Seq_Assign_Value (Alts (I).Asgns); Alts (I).Asgns := Get_Assign_Chain (Alts (I).Asgns); else Pasgns (Int32 (I)) := No_Seq_Assign_Value; end if; end loop; -- If: -- 1) All present values in PASGNS are static -- 2) There is no missing values *or* the previous value is -- static. -- 3) The default value is unused *or* it is static -- 4) All the values are equal. -- then assign directly. Sval := Is_Assign_Value_Array_Static (Wi, Pasgns.all); if Sval /= Null_Memtyp then -- Use static assignment. Phi_Assign_Static (Wi, Sval); else -- Compute the final value for each partial part of the wire. Partial_Assign_Init (List); Min_Off := 0; loop Off := Min_Off; -- Extract value of partial assignments to NETS. Extract_Merge_Partial_Assigns (Ctxt, Pasgns.all, Nets.all, Off, Wd); exit when Off = Uns32'Last and Wd = Width'Last; -- If a branch has no value, use the value before the case. -- Also do it for the default value! Last_Val := No_Net; for I in Nets'Range loop if Nets (I) = No_Net then if Last_Val = No_Net then Last_Val := Get_Current_Assign_Value (Ctxt, Wi, Off, Wd); end if; Nets (I) := Last_Val; end if; end loop; -- Extract default value (for missing alternative). if Others_Alt_Idx /= 0 then Default := Nets (Int32 (Others_Alt_Idx)); else Default := Build_Const_X (Ctxt, Wd); end if; if Nbr_Choices = 0 then Res := Default; else Res := Build_Pmux (Ctxt, Sel_Net, Default); Res_Inst := Get_Net_Parent (Res); Set_Location (Res_Inst, Get_Location (Stmt)); for I in 1 .. Nbr_Choices loop Connect (Get_Input (Res_Inst, Port_Nbr (2 + I - Nets'First)), Nets (I)); end loop; end if; Partial_Assign_Append (List, New_Partial_Assign (Res, Off)); Min_Off := Off + Wd; end loop; Merge_Partial_Assigns (Ctxt, Wi, List); end if; end; end loop; -- free. Free_Wire_Id_Array (Wires); Free_Alternative_Data_Array (Alts); Free_Seq_Assign_Value_Array (Pasgns); Free_Net_Array (Nets); end Synth_Case_Statement_Dynamic; procedure Synth_Case_Statement_Static_Array (C : in out Seq_Context; Stmt : Node; Sel : Valtyp) is Choices : constant Node := Get_Case_Statement_Alternative_Chain (Stmt); Choice : Node; Stmts : Node; Sel_Expr : Node; Sel_Val : Valtyp; begin -- Synth statements, extract choice value. Stmts := Null_Node; Choice := Choices; loop pragma Assert (Is_Valid (Choice)); if not Get_Same_Alternative_Flag (Choice) then Stmts := Get_Associated_Chain (Choice); end if; case Get_Kind (Choice) is when Iir_Kind_Choice_By_Expression => Sel_Expr := Get_Choice_Expression (Choice); Sel_Val := Synth_Expression_With_Basetype (C.Inst, Sel_Expr); if Is_Equal (Sel_Val, Sel) then Synth_Sequential_Statements (C, Stmts); exit; end if; when Iir_Kind_Choice_By_Others => Synth_Sequential_Statements (C, Stmts); exit; when others => raise Internal_Error; end case; Choice := Get_Chain (Choice); end loop; end Synth_Case_Statement_Static_Array; procedure Synth_Case_Statement_Static_Scalar (C : in out Seq_Context; Stmt : Node; Sel : Int64) is Choices : constant Node := Get_Case_Statement_Alternative_Chain (Stmt); Choice : Node; Stmts : Node; Sel_Expr : Node; begin -- Synth statements, extract choice value. Stmts := Null_Node; Choice := Choices; loop pragma Assert (Is_Valid (Choice)); if not Get_Same_Alternative_Flag (Choice) then Stmts := Get_Associated_Chain (Choice); end if; case Get_Kind (Choice) is when Iir_Kind_Choice_By_Expression => Sel_Expr := Get_Choice_Expression (Choice); if Vhdl.Evaluation.Eval_Pos (Sel_Expr) = Sel then Synth_Sequential_Statements (C, Stmts); exit; end if; when Iir_Kind_Choice_By_Others => Synth_Sequential_Statements (C, Stmts); exit; when Iir_Kind_Choice_By_Range => declare Bnd : Discrete_Range_Type; Is_In : Boolean; begin Synth_Discrete_Range (C.Inst, Get_Choice_Range (Choice), Bnd); case Bnd.Dir is when Dir_To => Is_In := Sel >= Bnd.Left and Sel <= Bnd.Right; when Dir_Downto => Is_In := Sel <= Bnd.Left and Sel >= Bnd.Right; end case; if Is_In then Synth_Sequential_Statements (C, Stmts); exit; end if; end; when others => raise Internal_Error; end case; Choice := Get_Chain (Choice); end loop; end Synth_Case_Statement_Static_Scalar; procedure Synth_Case_Statement (C : in out Seq_Context; Stmt : Node) is Expr : constant Node := Get_Expression (Stmt); Sel : Valtyp; begin Sel := Synth_Expression_With_Basetype (C.Inst, Expr); Strip_Const (Sel); if Is_Static (Sel.Val) then case Sel.Typ.Kind is when Type_Bit | Type_Logic | Type_Discrete => Synth_Case_Statement_Static_Scalar (C, Stmt, Read_Discrete (Sel)); when Type_Vector | Type_Array => Synth_Case_Statement_Static_Array (C, Stmt, Sel); when others => raise Internal_Error; end case; else Synth_Case_Statement_Dynamic (C, Stmt, Sel); end if; end Synth_Case_Statement; procedure Synth_Selected_Signal_Assignment (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is use Vhdl.Sem_Expr; Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Expr : constant Node := Get_Expression (Stmt); Choices : constant Node := Get_Selected_Waveform_Chain (Stmt); Targ : Target_Info; Targ_Type : Type_Acc; Case_Info : Choice_Info_Type; -- Array of alternatives Alts : Alternative_Data_Acc; Alt_Idx : Alternative_Index; Others_Alt_Idx : Alternative_Index; -- Array of choices. Contains tuple of (Value, Alternative). Nbr_Choices : Nat32; Nets : Net_Array_Acc; Sel : Valtyp; Sel_Net : Net; begin Targ := Synth_Target (Syn_Inst, Get_Target (Stmt)); Targ_Type := Targ.Targ_Type; -- Create a net for the expression. Sel := Synth_Expression_With_Basetype (Syn_Inst, Expr); Sel_Net := Get_Net (Ctxt, Sel); -- Count choices and alternatives. Count_Choices (Case_Info, Choices); -- Fill_Choices_Array (Case_Info, Choices); -- Allocate structures. -- Because there is no 1-1 link between choices and alternatives, -- create an array for the choices and an array for the alternatives. Alts := new Alternative_Data_Array (1 .. Alternative_Index (Case_Info.Nbr_Alternatives)); -- Compute number of non-default alternatives. Nbr_Choices := Nat32 (Case_Info.Nbr_Alternatives); if Case_Info.Others_Choice /= Null_Node then Nbr_Choices := Nbr_Choices - 1; end if; Nets := new Net_Array (1 .. Nbr_Choices); -- Synth statements, extract choice value. declare Choice, Wf : Node; Val : Valtyp; Choice_Idx, Other_Choice : Nat32; begin Alt_Idx := 0; Choice_Idx := 0; Other_Choice := 0; Choice := Choices; while Is_Valid (Choice) loop pragma Assert (not Get_Same_Alternative_Flag (Choice)); Wf := Get_Associated_Chain (Choice); Val := Synth_Waveform (Syn_Inst, Wf, Targ_Type); Alt_Idx := Alt_Idx + 1; Alts (Alt_Idx).Val := Get_Net (Ctxt, Val); Synth_Choice (Syn_Inst, Sel_Net, Sel.Typ, Nets.all, Other_Choice, Choice_Idx, Choice); end loop; pragma Assert (Choice_Idx = Nbr_Choices); Others_Alt_Idx := Alternative_Index (Other_Choice); end; -- Create the one-hot vector. if Nbr_Choices = 0 then Sel_Net := No_Net; else Sel_Net := Build2_Concat (Ctxt, Nets (1 .. Nbr_Choices)); end if; declare Res : Net; Res_Inst : Instance; Default : Net; begin -- Extract default value (for missing alternative). if Others_Alt_Idx /= 0 then Default := Alts (Others_Alt_Idx).Val; else Default := Build_Const_X (Ctxt, Targ_Type.W); end if; if Nbr_Choices = 0 then Res := Default; else Res := Build_Pmux (Ctxt, Sel_Net, Default); Res_Inst := Get_Net_Parent (Res); Set_Location (Res_Inst, Get_Location (Stmt)); for I in 1 .. Nbr_Choices loop Connect (Get_Input (Res_Inst, Port_Nbr (2 + I - Nets'First)), Alts (Alternative_Index (I)).Val); end loop; end if; Synth_Assignment (Syn_Inst, Targ, Create_Value_Net (Res, Targ_Type), Stmt); end; -- free. Free_Alternative_Data_Array (Alts); Free_Net_Array (Nets); end Synth_Selected_Signal_Assignment; function Synth_Label (Syn_Inst : Synth_Instance_Acc; Stmt : Node) return Sname is Label : constant Name_Id := Get_Label (Stmt); begin if Label = Null_Identifier then return No_Sname; else return New_Sname_User (Label, Get_Sname (Syn_Inst)); end if; end Synth_Label; function Is_Copyback_Interface (Inter : Node) return Boolean is begin case Iir_Parameter_Modes (Get_Mode (Inter)) is when Iir_In_Mode => return False; when Iir_Out_Mode | Iir_Inout_Mode => return Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration; end case; end Is_Copyback_Interface; type Association_Iterator_Kind is (Association_Function, Association_Operator); type Association_Iterator_Init (Kind : Association_Iterator_Kind := Association_Function) is record Inter_Chain : Node; case Kind is when Association_Function => Assoc_Chain : Node; when Association_Operator => Left : Node; Right : Node; end case; end record; function Association_Iterator_Build (Inter_Chain : Node; Assoc_Chain : Node) return Association_Iterator_Init is begin return Association_Iterator_Init'(Kind => Association_Function, Inter_Chain => Inter_Chain, Assoc_Chain => Assoc_Chain); end Association_Iterator_Build; function Association_Iterator_Build (Inter_Chain : Node; Left : Node; Right : Node) return Association_Iterator_Init is begin return Association_Iterator_Init'(Kind => Association_Operator, Inter_Chain => Inter_Chain, Left => Left, Right => Right); end Association_Iterator_Build; function Count_Associations (Init : Association_Iterator_Init) return Natural is Assoc : Node; Assoc_Inter : Node; Inter : Node; Nbr_Inout : Natural; begin case Init.Kind is when Association_Function => Nbr_Inout := 0; Assoc := Init.Assoc_Chain; Assoc_Inter := Init.Inter_Chain; while Is_Valid (Assoc) loop Inter := Get_Association_Interface (Assoc, Assoc_Inter); if Is_Copyback_Interface (Inter) then Nbr_Inout := Nbr_Inout + 1; end if; Next_Association_Interface (Assoc, Assoc_Inter); end loop; return Nbr_Inout; when Association_Operator => return 0; end case; end Count_Associations; type Association_Iterator (Kind : Association_Iterator_Kind := Association_Function) is record Inter : Node; case Kind is when Association_Function => First_Named_Assoc : Node; Next_Assoc : Node; when Association_Operator => Op1 : Node; Op2 : Node; end case; end record; procedure Association_Iterate_Init (Iterator : out Association_Iterator; Init : Association_Iterator_Init) is begin case Init.Kind is when Association_Function => Iterator := (Kind => Association_Function, Inter => Init.Inter_Chain, First_Named_Assoc => Null_Node, Next_Assoc => Init.Assoc_Chain); when Association_Operator => Iterator := (Kind => Association_Operator, Inter => Init.Inter_Chain, Op1 => Init.Left, Op2 => Init.Right); end case; end Association_Iterate_Init; -- Return the next association. -- ASSOC can be: -- * an Iir_Kind_Association_By_XXX node (normal case) -- * Null_Iir if INTER is not associated (and has a default value). -- * an expression (for operator association). procedure Association_Iterate_Next (Iterator : in out Association_Iterator; Inter : out Node; Assoc : out Node) is Formal : Node; begin Inter := Iterator.Inter; if Inter = Null_Node then -- End of iterator. Assoc := Null_Node; return; else -- Advance to the next interface for the next call. Iterator.Inter := Get_Chain (Iterator.Inter); end if; case Iterator.Kind is when Association_Function => if Iterator.First_Named_Assoc = Null_Node then Assoc := Iterator.Next_Assoc; if Assoc = Null_Node then -- No more association: open association. return; end if; Formal := Get_Formal (Assoc); if Formal = Null_Node then -- Association by position. -- Update for the next call. Iterator.Next_Assoc := Get_Chain (Assoc); return; end if; Iterator.First_Named_Assoc := Assoc; end if; -- Search by name. Assoc := Iterator.First_Named_Assoc; while Assoc /= Null_Node loop Formal := Get_Formal (Assoc); pragma Assert (Formal /= Null_Node); Formal := Get_Interface_Of_Formal (Formal); if Formal = Inter then -- Found. -- Optimize in case assocs are in order. if Assoc = Iterator.First_Named_Assoc then Iterator.First_Named_Assoc := Get_Chain (Assoc); end if; return; end if; Assoc := Get_Chain (Assoc); end loop; -- Not found: open association. return; when Association_Operator => Assoc := Iterator.Op1; Iterator.Op1 := Iterator.Op2; Iterator.Op2 := Null_Node; end case; end Association_Iterate_Next; procedure Synth_Subprogram_Association (Subprg_Inst : Synth_Instance_Acc; Caller_Inst : Synth_Instance_Acc; Init : Association_Iterator_Init; Infos : out Target_Info_Array) is pragma Assert (Infos'First = 1); Ctxt : constant Context_Acc := Get_Build (Caller_Inst); Inter : Node; Inter_Type : Type_Acc; Assoc : Node; Actual : Node; Val : Valtyp; Nbr_Inout : Natural; Iterator : Association_Iterator; Info : Target_Info; begin Set_Instance_Const (Subprg_Inst, True); Nbr_Inout := 0; -- Process in INTER order. Association_Iterate_Init (Iterator, Init); loop Association_Iterate_Next (Iterator, Inter, Assoc); exit when Inter = Null_Node; Inter_Type := Get_Subtype_Object (Caller_Inst, Get_Type (Inter)); case Iir_Parameter_Modes (Get_Mode (Inter)) is when Iir_In_Mode => if Assoc = Null_Node or else Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Actual := Get_Default_Value (Inter); Val := Synth_Expression_With_Type (Subprg_Inst, Actual, Inter_Type); else if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then Actual := Get_Actual (Assoc); else Actual := Assoc; end if; Val := Synth_Expression_With_Type (Caller_Inst, Actual, Inter_Type); end if; when Iir_Out_Mode | Iir_Inout_Mode => Actual := Get_Actual (Assoc); Info := Synth_Target (Caller_Inst, Actual); case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is when Iir_Kind_Interface_Constant_Declaration => raise Internal_Error; when Iir_Kind_Interface_Variable_Declaration => -- Always pass by value. Nbr_Inout := Nbr_Inout + 1; Infos (Nbr_Inout) := Info; if Info.Kind /= Target_Memory and then Is_Static (Info.Obj.Val) then Val := Create_Value_Memory (Info.Targ_Type); Copy_Memory (Val.Val.Mem, Info.Obj.Val.Mem + Info.Off.Mem_Off, Info.Targ_Type.Sz); else Val := Synth_Read (Caller_Inst, Info, Assoc); end if; when Iir_Kind_Interface_Signal_Declaration => -- Always pass by reference (use an alias). if Info.Kind = Target_Memory then raise Internal_Error; end if; Val := Create_Value_Alias (Info.Obj, Info.Off, Info.Targ_Type); when Iir_Kind_Interface_File_Declaration => Val := Info.Obj; when Iir_Kind_Interface_Quantity_Declaration => raise Internal_Error; end case; end case; if Val = No_Valtyp then Set_Error (Subprg_Inst); return; end if; -- FIXME: conversion only for constants, reshape for all. Val := Synth_Subtype_Conversion (Ctxt, Val, Inter_Type, True, Assoc); if Get_Instance_Const (Subprg_Inst) and then not Is_Static (Val.Val) then Set_Instance_Const (Subprg_Inst, False); end if; case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is when Iir_Kind_Interface_Constant_Declaration => -- Pass by reference. Create_Object (Subprg_Inst, Inter, Val); when Iir_Kind_Interface_Variable_Declaration => -- Arguments are passed by copy. if Is_Static (Val.Val) or else Get_Mode (Inter) = Iir_In_Mode then Val := Unshare (Val, Current_Pool); else -- Will be changed to a wire. null; end if; Create_Object (Subprg_Inst, Inter, Val); when Iir_Kind_Interface_Signal_Declaration => Create_Object (Subprg_Inst, Inter, Val); when Iir_Kind_Interface_File_Declaration => Create_Object (Subprg_Inst, Inter, Val); when Iir_Kind_Interface_Quantity_Declaration => raise Internal_Error; end case; end loop; end Synth_Subprogram_Association; procedure Synth_Subprogram_Association (Subprg_Inst : Synth_Instance_Acc; Caller_Inst : Synth_Instance_Acc; Inter_Chain : Node; Assoc_Chain : Node) is Infos : Target_Info_Array (1 .. 0); pragma Unreferenced (Infos); Init : Association_Iterator_Init; begin Init := Association_Iterator_Build (Inter_Chain, Assoc_Chain); Synth_Subprogram_Association (Subprg_Inst, Caller_Inst, Init, Infos); end Synth_Subprogram_Association; -- Create wires for out and inout interface variables. procedure Synth_Subprogram_Association_Wires (Subprg_Inst : Synth_Instance_Acc; Init : Association_Iterator_Init) is Ctxt : constant Context_Acc := Get_Build (Subprg_Inst); Inter : Node; Assoc : Node; Val : Valtyp; Iterator : Association_Iterator; Wire : Wire_Id; begin -- Process in INTER order. Association_Iterate_Init (Iterator, Init); loop Association_Iterate_Next (Iterator, Inter, Assoc); exit when Inter = Null_Node; if Get_Mode (Inter) in Iir_Out_Modes and then Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration then Val := Get_Value (Subprg_Inst, Inter); -- Arguments are passed by copy. Wire := Alloc_Wire (Wire_Variable, Val.Typ, Inter); Set_Wire_Gate (Wire, Get_Net (Ctxt, Val)); Val := Create_Value_Wire (Wire, Val.Typ); Create_Object_Force (Subprg_Inst, Inter, No_Valtyp); Create_Object_Force (Subprg_Inst, Inter, Val); end if; end loop; end Synth_Subprogram_Association_Wires; procedure Synth_Subprogram_Back_Association (Subprg_Inst : Synth_Instance_Acc; Caller_Inst : Synth_Instance_Acc; Init : Association_Iterator_Init; Infos : Target_Info_Array) is pragma Assert (Infos'First = 1); Inter : Node; Assoc : Node; Assoc_Inter : Node; Val : Valtyp; Nbr_Inout : Natural; begin Nbr_Inout := 0; pragma Assert (Init.Kind = Association_Function); Assoc := Init.Assoc_Chain; Assoc_Inter := Init.Inter_Chain; while Is_Valid (Assoc) loop Inter := Get_Association_Interface (Assoc, Assoc_Inter); if Is_Copyback_Interface (Inter) then if not Get_Whole_Association_Flag (Assoc) then raise Internal_Error; end if; Nbr_Inout := Nbr_Inout + 1; Val := Get_Value (Subprg_Inst, Inter); Synth_Assignment (Caller_Inst, Infos (Nbr_Inout), Val, Assoc); -- Free wire used for out/inout interface variables. if Val.Val.Kind = Value_Wire then Phi_Discard_Wires (Val.Val.W, No_Wire_Id); Free_Wire (Val.Val.W); end if; end if; Next_Association_Interface (Assoc, Assoc_Inter); end loop; pragma Assert (Nbr_Inout = Infos'Last); end Synth_Subprogram_Back_Association; function Build_Control_Signal (Syn_Inst : Synth_Instance_Acc; W : Width; Loc : Source.Syn_Src) return Net is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Res : Net; begin Res := Build_Signal (Ctxt, New_Internal_Name (Ctxt), W); Set_Location (Res, Loc); return Res; end Build_Control_Signal; function Synth_Dynamic_Subprogram_Call (Syn_Inst : Synth_Instance_Acc; Sub_Inst : Synth_Instance_Acc; Call : Node; Init : Association_Iterator_Init; Infos : Target_Info_Array) return Valtyp is Imp : constant Node := Get_Implementation (Call); Is_Func : constant Boolean := Is_Function_Declaration (Imp); Bod : constant Node := Vhdl.Sem_Inst.Get_Subprogram_Body_Origin (Imp); Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Res : Valtyp; C : Seq_Context (Mode_Dynamic); Wire_Mark : Wire_Id; Subprg_Phi : Phi_Type; begin Mark (Wire_Mark); C := (Mode => Mode_Dynamic, Inst => Sub_Inst, Cur_Loop => null, W_En => No_Wire_Id, W_Ret => No_Wire_Id, W_Val => No_Wire_Id, Ret_Init => No_Net, Ret_Value => No_Valtyp, Ret_Typ => null, Nbr_Ret => 0); C.W_En := Alloc_Wire (Wire_Variable, Bit_Type, Imp); C.W_Ret := Alloc_Wire (Wire_Variable, Bit_Type, Imp); if Is_Func then C.W_Val := Alloc_Wire (Wire_Variable, null, Imp); end if; -- Create a phi so that all assignments are gathered. Push_Phi; Synth_Subprogram_Association_Wires (Sub_Inst, Init); if Is_Func then -- Set a default value for the return. C.Ret_Typ := Get_Subtype_Object (Syn_Inst, Get_Return_Type (Imp)); Set_Wire_Gate (C.W_Val, Build_Control_Signal (Sub_Inst, C.Ret_Typ.W, Imp)); C.Ret_Init := Build_Const_X (Ctxt, C.Ret_Typ.W); Phi_Assign_Net (Ctxt, C.W_Val, C.Ret_Init, 0); end if; Set_Wire_Gate (C.W_En, Build_Control_Signal (Sub_Inst, 1, Imp)); Phi_Assign_Static (C.W_En, Bit1); Set_Wire_Gate (C.W_Ret, Build_Control_Signal (Sub_Inst, 1, Imp)); Phi_Assign_Static (C.W_Ret, Bit1); Decls.Synth_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); if not Is_Error (C.Inst) then Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Bod)); end if; if Is_Error (C.Inst) then Res := No_Valtyp; else if Is_Func then if C.Nbr_Ret = 0 then raise Internal_Error; elsif C.Nbr_Ret = 1 and then Is_Static (C.Ret_Value.Val) then Res := C.Ret_Value; else Res := Create_Value_Net (Get_Current_Value (Ctxt, C.W_Val), C.Ret_Value.Typ); end if; else Res := No_Valtyp; Synth_Subprogram_Back_Association (C.Inst, Syn_Inst, Init, Infos); end if; end if; Pop_Phi (Subprg_Phi); Decls.Finalize_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); pragma Unreferenced (Infos); -- Propagate assignments. -- Wires that have been created for this subprogram will be destroyed. -- But assignment for outer wires (passed through parameters) have -- to be kept. We cannot merge phi because this won't be allowed for -- local wires. Propagate_Phi_Until_Mark (Ctxt, Subprg_Phi, Wire_Mark); -- Free wires. -- These wires are currently unassigned because they were created -- within the Phi. Free_Wire (C.W_En); Free_Wire (C.W_Ret); if Is_Func then Free_Wire (C.W_Val); end if; Release (Wire_Mark); return Res; end Synth_Dynamic_Subprogram_Call; function Synth_Static_Subprogram_Call (Syn_Inst : Synth_Instance_Acc; Sub_Inst : Synth_Instance_Acc; Call : Node; Bod : Node; Init : Association_Iterator_Init; Infos : Target_Info_Array) return Valtyp is Imp : constant Node := Get_Implementation (Call); Is_Func : constant Boolean := Is_Function_Declaration (Imp); Res : Valtyp; C : Seq_Context (Mode_Static); begin C := (Mode_Static, Inst => Sub_Inst, Cur_Loop => null, S_En => True, Ret_Value => No_Valtyp, Ret_Typ => null, Nbr_Ret => 0); if Is_Func then -- Set a default value for the return. C.Ret_Typ := Get_Subtype_Object (Syn_Inst, Get_Return_Type (Imp)); end if; Synth_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); if not Is_Error (C.Inst) then Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Bod)); end if; if Is_Error (C.Inst) then Res := No_Valtyp; else if Is_Func then if C.Nbr_Ret = 0 then Error_Msg_Synth (+Call, "function call completed without a return statement"); Res := No_Valtyp; else pragma Assert (C.Nbr_Ret = 1); pragma Assert (Is_Static (C.Ret_Value.Val)); Res := C.Ret_Value; end if; else Res := No_Valtyp; Synth_Subprogram_Back_Association (C.Inst, Syn_Inst, Init, Infos); end if; end if; Decls.Finalize_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); pragma Unreferenced (Infos); return Res; end Synth_Static_Subprogram_Call; function Synth_Subprogram_Call (Syn_Inst : Synth_Instance_Acc; Call : Node; Init : Association_Iterator_Init) return Valtyp is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Imp : constant Node := Get_Implementation (Call); Is_Func : constant Boolean := Is_Function_Declaration (Imp); Bod : constant Node := Vhdl.Sem_Inst.Get_Subprogram_Body_Origin (Imp); Nbr_Inout : constant Natural := Count_Associations (Init); Infos : Target_Info_Array (1 .. Nbr_Inout); Area_Mark : Areapools.Mark_Type; Res : Valtyp; Sub_Inst : Synth_Instance_Acc; Up_Inst : Synth_Instance_Acc; begin Areapools.Mark (Area_Mark, Instance_Pool.all); Up_Inst := Get_Instance_By_Scope (Syn_Inst, Get_Parent_Scope (Imp)); Sub_Inst := Make_Instance (Up_Inst, Bod, New_Internal_Name (Ctxt)); Set_Instance_Base (Sub_Inst, Syn_Inst); Synth_Subprogram_Association (Sub_Inst, Syn_Inst, Init, Infos); if Is_Error (Sub_Inst) then Res := No_Valtyp; else if not Is_Func then if Get_Purity_State (Imp) /= Pure then Set_Instance_Const (Sub_Inst, False); end if; end if; if Get_Instance_Const (Sub_Inst) then Res := Synth_Static_Subprogram_Call (Syn_Inst, Sub_Inst, Call, Bod, Init, Infos); else Res := Synth_Dynamic_Subprogram_Call (Syn_Inst, Sub_Inst, Call, Init, Infos); end if; end if; -- Propagate error. if Is_Error (Sub_Inst) then Set_Error (Syn_Inst); end if; if Debugger.Flag_Need_Debug then Debugger.Debug_Leave (Sub_Inst); end if; Free_Instance (Sub_Inst); Areapools.Release (Area_Mark, Instance_Pool.all); return Res; end Synth_Subprogram_Call; function Synth_Subprogram_Call (Syn_Inst : Synth_Instance_Acc; Call : Node) return Valtyp is Imp : constant Node := Get_Implementation (Call); Assoc_Chain : constant Node := Get_Parameter_Association_Chain (Call); Inter_Chain : constant Node := Get_Interface_Declaration_Chain (Imp); Init : Association_Iterator_Init; begin Init := Association_Iterator_Build (Inter_Chain, Assoc_Chain); return Synth_Subprogram_Call (Syn_Inst, Call, Init); end Synth_Subprogram_Call; function Synth_User_Operator (Syn_Inst : Synth_Instance_Acc; Left_Expr : Node; Right_Expr : Node; Expr : Node) return Valtyp is Imp : constant Node := Get_Implementation (Expr); Inter_Chain : constant Node := Get_Interface_Declaration_Chain (Imp); Init : Association_Iterator_Init; begin Init := Association_Iterator_Build (Inter_Chain, Left_Expr, Right_Expr); return Synth_Subprogram_Call (Syn_Inst, Expr, Init); end Synth_User_Operator; procedure Synth_Implicit_Procedure_Call (Syn_Inst : Synth_Instance_Acc; Call : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Imp : constant Node := Get_Implementation (Call); Assoc_Chain : constant Node := Get_Parameter_Association_Chain (Call); Inter_Chain : constant Node := Get_Interface_Declaration_Chain (Imp); Init : constant Association_Iterator_Init := Association_Iterator_Build (Inter_Chain, Assoc_Chain); Nbr_Inout : constant Natural := Count_Associations (Init); Infos : Target_Info_Array (1 .. Nbr_Inout); Area_Mark : Areapools.Mark_Type; Sub_Inst : Synth_Instance_Acc; begin Areapools.Mark (Area_Mark, Instance_Pool.all); Sub_Inst := Make_Instance (Syn_Inst, Imp, New_Internal_Name (Ctxt)); Synth_Subprogram_Association (Sub_Inst, Syn_Inst, Init, Infos); Synth.Static_Proc.Synth_Static_Procedure (Sub_Inst, Imp, Call); Synth_Subprogram_Back_Association (Sub_Inst, Syn_Inst, Init, Infos); Free_Instance (Sub_Inst); Areapools.Release (Area_Mark, Instance_Pool.all); end Synth_Implicit_Procedure_Call; procedure Synth_Procedure_Call (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Call : constant Node := Get_Procedure_Call (Stmt); Imp : constant Node := Get_Implementation (Call); Res : Valtyp; begin case Get_Implicit_Definition (Imp) is when Iir_Predefined_None => if Get_Foreign_Flag (Imp) then Error_Msg_Synth (+Stmt, "call to foreign %n is not supported", +Imp); else Res := Synth_Subprogram_Call (Syn_Inst, Call); pragma Assert (Res = No_Valtyp); end if; when others => Synth_Implicit_Procedure_Call (Syn_Inst, Call); end case; end Synth_Procedure_Call; procedure Update_Index (Rng : Discrete_Range_Type; V : in out Valtyp) is T : Int64; begin T := Read_Discrete (V); case Rng.Dir is when Dir_To => T := T + 1; when Dir_Downto => T := T - 1; end case; Write_Discrete (V, T); end Update_Index; -- Return True iff WID is a static wire and its value is V. function Is_Static_Bit (Wid : Wire_Id; V : Ghdl_U8) return Boolean is M : Memtyp; begin if not Is_Static_Wire (Wid) then return False; end if; M := Get_Static_Wire (Wid); return Read_U8 (M) = V; end Is_Static_Bit; function Is_Static_Bit0 (Wid : Wire_Id) return Boolean is begin return Is_Static_Bit (Wid, 0); end Is_Static_Bit0; function Is_Static_Bit1 (Wid : Wire_Id) return Boolean is begin return Is_Static_Bit (Wid, 1); end Is_Static_Bit1; pragma Inline (Is_Static_Bit0); pragma Inline (Is_Static_Bit1); procedure Loop_Control_Init (C : Seq_Context; Stmt : Node) is Lc : constant Loop_Context_Acc := C.Cur_Loop; begin -- We might create new wires that will be destroy at the end of the -- loop. Use mark and sweep to control their lifetime. Mark (C.Cur_Loop.Wire_Mark); if Lc.Prev_Loop /= null and then Lc.Prev_Loop.Need_Quit then -- An exit or next statement that targets an outer loop may suspend -- the execution of this loop. Lc.W_Quit := Alloc_Wire (Wire_Variable, Bit_Type, Lc.Loop_Stmt); Set_Wire_Gate (Lc.W_Quit, Build_Control_Signal (C.Inst, 1, Stmt)); Phi_Assign_Static (Lc.W_Quit, Bit1); end if; if Get_Exit_Flag (Stmt) or else Get_Next_Flag (Stmt) then -- There is an exit or next statement that target this loop. -- We need to save W_En, as if the execution is suspended due to -- exit or next, it will resume at the end of the loop. if Is_Static_Wire (C.W_En) then pragma Assert (Is_Static_Bit1 (C.W_En)); Lc.Saved_En := No_Net; else Lc.Saved_En := Get_Current_Value (null, C.W_En); end if; -- Subloops may be suspended if there is an exit or a next statement -- for this loop within subloops. Lc.Need_Quit := True; end if; if Get_Exit_Flag (Stmt) then -- There is an exit statement for this loop. Create the wire. Lc.W_Exit := Alloc_Wire (Wire_Variable, Bit_Type, Lc.Loop_Stmt); Set_Wire_Gate (Lc.W_Exit, Build_Control_Signal (C.Inst, 1, Stmt)); Phi_Assign_Static (Lc.W_Exit, Bit1); end if; end Loop_Control_Init; procedure Loop_Control_And_Start (Is_Net : out Boolean; S : out Boolean; N : out Net; En : Net) is begin if En = No_Net then Is_Net := False; N := No_Net; S := True; else Is_Net := True; N := En; S := True; end if; end Loop_Control_And_Start; procedure Loop_Control_And (C : Seq_Context; Is_Net : in out Boolean; S : in out Boolean; N : in out Net; R : Wire_Id) is Res : Net; begin if R = No_Wire_Id or else Is_Static_Bit1 (R) then -- No change. return; end if; if Is_Static_Bit0 (R) then -- Stays 0. Is_Net := False; S := False; N := No_Net; return; end if; if not Is_Net and then not S then -- Was 0, remains 0. return; end if; pragma Assert (Is_Net or else S); -- Optimize common cases. Res := Get_Current_Value (null, R); if Is_Net then N := Build_Dyadic (Get_Build (C.Inst), Id_And, N, Res); Set_Location (N, C.Cur_Loop.Loop_Stmt); else N := Res; end if; Is_Net := True; end Loop_Control_And; procedure Loop_Control_And_Assign (C : Seq_Context; Is_Net : Boolean; S : Boolean; N : Net; W : Wire_Id) is begin if Is_Net then Phi_Assign_Net (Get_Build (C.Inst), W, N, 0); else if S then Phi_Assign_Static (W, Bit1); else Phi_Assign_Static (W, Bit0); end if; end if; end Loop_Control_And_Assign; procedure Loop_Control_Update (C : Seq_Context) is Lc : constant Loop_Context_Acc := C.Cur_Loop; N : Net; S : Boolean; Is_Net : Boolean; begin if not Lc.Need_Quit then -- No next/exit statement for this loop. So no control. return; end if; -- Execution continue iff: -- 1. Loop was enabled (Lc.Saved_En) Loop_Control_And_Start (Is_Net, S, N, Lc.Saved_En); -- 2. No return (C.W_Ret) Loop_Control_And (C, Is_Net, S, N, C.W_Ret); -- 3. No exit. Loop_Control_And (C, Is_Net, S, N, Lc.W_Exit); -- 4. No quit. Loop_Control_And (C, Is_Net, S, N, Lc.W_Quit); Loop_Control_And_Assign (C, Is_Net, S, N, C.W_En); end Loop_Control_Update; procedure Loop_Control_Finish (C : Seq_Context) is Lc : constant Loop_Context_Acc := C.Cur_Loop; N : Net; S : Boolean; Is_Net : Boolean; begin -- Execution continue after this loop iff: -- 1. Loop was enabled (Lc.Saved_En) Loop_Control_And_Start (Is_Net, S, N, Lc.Saved_En); -- 2. No return (C.W_Ret) Loop_Control_And (C, Is_Net, S, N, C.W_Ret); -- 3. No quit (C.W_Quit) Loop_Control_And (C, Is_Net, S, N, Lc.W_Quit); Phi_Discard_Wires (Lc.W_Quit, Lc.W_Exit); if Lc.W_Quit /= No_Wire_Id then Free_Wire (Lc.W_Quit); end if; if Lc.W_Exit /= No_Wire_Id then Free_Wire (Lc.W_Exit); end if; Release (C.Cur_Loop.Wire_Mark); Loop_Control_And_Assign (C, Is_Net, S, N, C.W_En); end Loop_Control_Finish; procedure Synth_Dynamic_Exit_Next_Statement (C : in out Seq_Context; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (C.Inst); Cond : constant Node := Get_Condition (Stmt); Is_Exit : constant Boolean := Get_Kind (Stmt) = Iir_Kind_Exit_Statement; Static_Cond : Boolean; Loop_Label : Node; Lc : Loop_Context_Acc; Cond_Val : Valtyp; Phi_True : Phi_Type; Phi_False : Phi_Type; begin if Cond /= Null_Node then Cond_Val := Synth_Expression (C.Inst, Cond); Static_Cond := Is_Static_Val (Cond_Val.Val); if Static_Cond then if Get_Static_Discrete (Cond_Val) = 0 then -- Not executed. return; end if; else -- Create a branch for the True case. Push_Phi; end if; end if; -- Execution is suspended for the current sequence of statements. Phi_Assign_Static (C.W_En, Bit0); Lc := C.Cur_Loop; -- Compute the loop statement indicated by the exit/next statement. Loop_Label := Get_Loop_Label (Stmt); if Loop_Label = Null_Node then Loop_Label := Lc.Loop_Stmt; else Loop_Label := Get_Named_Entity (Loop_Label); end if; -- Update the W_Exit and W_Quit flags for the loops. All the loops -- until the label are canceled. loop if Lc.Loop_Stmt = Loop_Label then -- Final loop. if Is_Exit then Phi_Assign_Static (Lc.W_Exit, Bit0); end if; exit; else Phi_Assign_Static (Lc.W_Quit, Bit0); end if; Lc := Lc.Prev_Loop; end loop; if Cond /= Null_Node and not Static_Cond then Pop_Phi (Phi_True); -- If the condition is false, do nothing. Push_Phi; Pop_Phi (Phi_False); Merge_Phis (Ctxt, Get_Net (Ctxt, Cond_Val), Phi_True, Phi_False, Stmt); end if; end Synth_Dynamic_Exit_Next_Statement; procedure Synth_Static_Exit_Next_Statement (C : in out Seq_Context; Stmt : Node) is Cond : constant Node := Get_Condition (Stmt); Is_Exit : constant Boolean := Get_Kind (Stmt) = Iir_Kind_Exit_Statement; Loop_Label : Node; Lc : Loop_Context_Acc; Cond_Val : Valtyp; begin if Cond /= Null_Node then Cond_Val := Synth_Expression (C.Inst, Cond); if Cond_Val = No_Valtyp then Set_Error (C.Inst); return; end if; pragma Assert (Is_Static_Val (Cond_Val.Val)); if Get_Static_Discrete (Cond_Val) = 0 then -- Not executed. return; end if; end if; -- Execution is suspended. C.S_En := False; Lc := C.Cur_Loop; Loop_Label := Get_Loop_Label (Stmt); if Loop_Label = Null_Node then Loop_Label := Lc.Loop_Stmt; else Loop_Label := Get_Named_Entity (Loop_Label); end if; loop if Lc.Loop_Stmt = Loop_Label then if Is_Exit then Lc.S_Exit := True; end if; exit; else Lc.S_Quit := True; end if; Lc := Lc.Prev_Loop; end loop; end Synth_Static_Exit_Next_Statement; procedure Init_For_Loop_Statement (C : in out Seq_Context; Stmt : Node; Val : out Valtyp) is Iterator : constant Node := Get_Parameter_Specification (Stmt); It_Type : constant Node := Get_Declaration_Type (Iterator); It_Rng : Type_Acc; begin if It_Type /= Null_Node then Synth_Subtype_Indication (C.Inst, It_Type); end if; -- Initial value. It_Rng := Get_Subtype_Object (C.Inst, Get_Type (Iterator)); Val := Create_Value_Discrete (It_Rng.Drange.Left, It_Rng); Create_Object (C.Inst, Iterator, Val); end Init_For_Loop_Statement; procedure Finish_For_Loop_Statement (C : in out Seq_Context; Stmt : Node) is Iterator : constant Node := Get_Parameter_Specification (Stmt); It_Type : constant Node := Get_Declaration_Type (Iterator); begin Destroy_Object (C.Inst, Iterator); if It_Type /= Null_Node then Destroy_Object (C.Inst, It_Type); end if; end Finish_For_Loop_Statement; procedure Synth_Dynamic_For_Loop_Statement (C : in out Seq_Context; Stmt : Node) is Stmts : constant Node := Get_Sequential_Statement_Chain (Stmt); Val : Valtyp; Lc : aliased Loop_Context (Mode_Dynamic); begin Lc := (Mode => Mode_Dynamic, Prev_Loop => C.Cur_Loop, Loop_Stmt => Stmt, Need_Quit => False, Saved_En => No_Net, W_Exit => No_Wire_Id, W_Quit => No_Wire_Id, Wire_Mark => No_Wire_Id); C.Cur_Loop := Lc'Unrestricted_Access; Loop_Control_Init (C, Stmt); Init_For_Loop_Statement (C, Stmt, Val); while In_Range (Val.Typ.Drange, Read_Discrete (Val)) loop Synth_Sequential_Statements (C, Stmts); Update_Index (Val.Typ.Drange, Val); Loop_Control_Update (C); -- Constant exit. exit when Is_Static_Bit0 (C.W_En); -- FIXME: dynamic exits. end loop; Loop_Control_Finish (C); Finish_For_Loop_Statement (C, Stmt); C.Cur_Loop := Lc.Prev_Loop; end Synth_Dynamic_For_Loop_Statement; procedure Synth_Static_For_Loop_Statement (C : in out Seq_Context; Stmt : Node) is Stmts : constant Node := Get_Sequential_Statement_Chain (Stmt); Val : Valtyp; Lc : aliased Loop_Context (Mode_Static); begin Lc := (Mode_Static, Prev_Loop => C.Cur_Loop, Loop_Stmt => Stmt, S_Exit => False, S_Quit => False); C.Cur_Loop := Lc'Unrestricted_Access; Init_For_Loop_Statement (C, Stmt, Val); while In_Range (Val.Typ.Drange, Read_Discrete (Val)) loop Synth_Sequential_Statements (C, Stmts); C.S_En := True; Update_Index (Val.Typ.Drange, Val); exit when Lc.S_Exit or Lc.S_Quit or C.Nbr_Ret > 0; end loop; Finish_For_Loop_Statement (C, Stmt); C.Cur_Loop := Lc.Prev_Loop; end Synth_Static_For_Loop_Statement; procedure Synth_Dynamic_While_Loop_Statement (C : in out Seq_Context; Stmt : Node) is Stmts : constant Node := Get_Sequential_Statement_Chain (Stmt); Cond : constant Node := Get_Condition (Stmt); Val : Valtyp; Lc : aliased Loop_Context (Mode_Dynamic); Iter_Nbr : Natural; begin Lc := (Mode => Mode_Dynamic, Prev_Loop => C.Cur_Loop, Loop_Stmt => Stmt, Need_Quit => False, Saved_En => No_Net, W_Exit => No_Wire_Id, W_Quit => No_Wire_Id, Wire_Mark => No_Wire_Id); C.Cur_Loop := Lc'Unrestricted_Access; Iter_Nbr := 0; Loop_Control_Init (C, Stmt); loop if Cond /= Null_Node then Val := Synth_Expression_With_Type (C.Inst, Cond, Boolean_Type); if not Is_Static (Val.Val) then Error_Msg_Synth (+Cond, "loop condition must be static"); exit; end if; exit when Read_Discrete (Val) = 0; end if; Synth_Sequential_Statements (C, Stmts); Loop_Control_Update (C); -- Exit from the loop if W_Exit/W_Ret/W_Quit = 0 exit when Lc.W_Exit /= No_Wire_Id and then Is_Static_Bit0 (Lc.W_Exit); exit when C.W_Ret /= No_Wire_Id and then Is_Static_Bit0 (C.W_Ret); exit when Lc.W_Quit /= No_Wire_Id and then Is_Static_Bit0 (Lc.W_Quit); Iter_Nbr := Iter_Nbr + 1; if Iter_Nbr > Flags.Flag_Max_Loop and Flags.Flag_Max_Loop /= 0 then Error_Msg_Synth (+Stmt, "maximum number of iterations (%v) reached", +Uns32 (Flags.Flag_Max_Loop)); exit; end if; end loop; Loop_Control_Finish (C); C.Cur_Loop := Lc.Prev_Loop; end Synth_Dynamic_While_Loop_Statement; procedure Synth_Static_While_Loop_Statement (C : in out Seq_Context; Stmt : Node) is Stmts : constant Node := Get_Sequential_Statement_Chain (Stmt); Cond : constant Node := Get_Condition (Stmt); Val : Valtyp; Lc : aliased Loop_Context (Mode_Static); begin Lc := (Mode => Mode_Static, Prev_Loop => C.Cur_Loop, Loop_Stmt => Stmt, S_Exit => False, S_Quit => False); C.Cur_Loop := Lc'Unrestricted_Access; loop if Cond /= Null_Node then Val := Synth_Expression_With_Type (C.Inst, Cond, Boolean_Type); pragma Assert (Is_Static (Val.Val)); exit when Read_Discrete (Val) = 0; end if; Synth_Sequential_Statements (C, Stmts); C.S_En := True; -- Exit from the loop if S_Exit/S_Quit exit when Lc.S_Exit or Lc.S_Quit or C.Nbr_Ret > 0; end loop; C.Cur_Loop := Lc.Prev_Loop; end Synth_Static_While_Loop_Statement; procedure Synth_Return_Statement (C : in out Seq_Context; Stmt : Node) is Is_Dyn : constant Boolean := not Get_Instance_Const (C.Inst); Ctxt : constant Context_Acc := Get_Build (C.Inst); Val : Valtyp; Expr : constant Node := Get_Expression (Stmt); begin if Expr /= Null_Node then -- Return in function. Val := Synth_Expression_With_Type (C.Inst, Expr, C.Ret_Typ); if Val = No_Valtyp then Set_Error (C.Inst); return; end if; Val := Synth_Subtype_Conversion (Ctxt, Val, C.Ret_Typ, True, Stmt); if C.Nbr_Ret = 0 then C.Ret_Value := Val; if not Is_Bounded_Type (C.Ret_Typ) then -- The function was declared with an unconstrained return type. -- Now that a value has been returned, we know the subtype of -- the returned values. So adjust it. -- All the returned values must have the same length. C.Ret_Typ := Val.Typ; if Is_Dyn then Set_Width (Get_Wire_Gate (C.W_Val), C.Ret_Typ.W); Set_Width (C.Ret_Init, C.Ret_Typ.W); end if; end if; end if; if Is_Dyn then Phi_Assign_Net (Ctxt, C.W_Val, Get_Net (Ctxt, Val), 0); end if; end if; if Is_Dyn then -- The subprogram has returned. Do not execute further statements. Phi_Assign_Static (C.W_En, Bit0); if C.W_Ret /= No_Wire_Id then Phi_Assign_Static (C.W_Ret, Bit0); end if; end if; C.Nbr_Ret := C.Nbr_Ret + 1; end Synth_Return_Statement; procedure Synth_Static_Report (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is use Simple_IO; Is_Report : constant Boolean := Get_Kind (Stmt) = Iir_Kind_Report_Statement; Rep_Expr : constant Node := Get_Report_Expression (Stmt); Sev_Expr : constant Node := Get_Severity_Expression (Stmt); Rep : Valtyp; Sev : Valtyp; Sev_V : Natural; begin if Rep_Expr /= Null_Node then Rep := Synth_Expression_With_Basetype (Syn_Inst, Rep_Expr); if Rep = No_Valtyp then Set_Error (Syn_Inst); return; end if; Strip_Const (Rep); end if; if Sev_Expr /= Null_Node then Sev := Synth_Expression (Syn_Inst, Sev_Expr); if Sev = No_Valtyp then Set_Error (Syn_Inst); return; end if; Strip_Const (Sev); end if; Put_Err (Disp_Location (Stmt)); Put_Err (":("); if Is_Report then Put_Err ("report"); else Put_Err ("assertion"); end if; Put_Err (' '); if Sev = No_Valtyp then if Is_Report then Sev_V := 0; else Sev_V := 2; end if; else Sev_V := Natural (Read_Discrete (Sev)); end if; case Sev_V is when Note_Severity => Put_Err ("note"); when Warning_Severity => Put_Err ("warning"); when Error_Severity => Put_Err ("error"); when Failure_Severity => Put_Err ("failure"); when others => Put_Err ("??"); end case; Put_Err ("): "); if Rep = No_Valtyp then Put_Line_Err ("assertion failure"); else Put_Line_Err (Value_To_String (Rep)); end if; if Sev_V >= Flags.Severity_Level then Error_Msg_Synth (+Stmt, "error due to assertion failure"); end if; end Synth_Static_Report; procedure Synth_Static_Report_Statement (C : Seq_Context; Stmt : Node) is begin Synth_Static_Report (C.Inst, Stmt); end Synth_Static_Report_Statement; procedure Synth_Static_Assertion_Statement (C : Seq_Context; Stmt : Node) is Cond : Valtyp; begin Cond := Synth_Expression (C.Inst, Get_Assertion_Condition (Stmt)); if Cond = No_Valtyp then Set_Error (C.Inst); return; end if; pragma Assert (Is_Static (Cond.Val)); Strip_Const (Cond); if Read_Discrete (Cond) = 1 then return; end if; Synth_Static_Report (C.Inst, Stmt); end Synth_Static_Assertion_Statement; procedure Synth_Dynamic_Assertion_Statement (C : Seq_Context; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (C.Inst); Loc : constant Location_Type := Get_Location (Stmt); Cond : Valtyp; N : Net; En : Net; Inst : Instance; begin if not Flags.Flag_Formal then return; end if; Cond := Synth_Expression (C.Inst, Get_Assertion_Condition (Stmt)); if Cond = No_Valtyp then Set_Error (C.Inst); return; end if; N := Get_Net (Ctxt, Cond); En := Phi_Enable (Ctxt, Stmt); if En /= No_Net then -- Build: En -> Cond N := Build2_Imp (Ctxt, En, N, Loc); end if; Inst := Build_Assert (Ctxt, Synth_Label (C.Inst, Stmt), N); Set_Location (Inst, Loc); end Synth_Dynamic_Assertion_Statement; procedure Synth_Sequential_Statements (C : in out Seq_Context; Stmts : Node) is Is_Dyn : constant Boolean := not Get_Instance_Const (C.Inst); Ctxt : constant Context_Acc := Get_Build (C.Inst); Stmt : Node; Phi_T, Phi_F : Phi_Type; Has_Phi : Boolean; begin Stmt := Stmts; while Is_Valid (Stmt) loop if Is_Dyn then pragma Assert (not Is_Static_Bit0 (C.W_En)); Has_Phi := not Is_Static_Bit1 (C.W_En); if Has_Phi then Push_Phi; end if; end if; if Flags.Flag_Trace_Statements then declare Name : Name_Id; Line : Natural; Col : Natural; begin Files_Map.Location_To_Position (Get_Location (Stmt), Name, Line, Col); Simple_IO.Put_Line ("Execute statement at " & Name_Table.Image (Name) & Natural'Image (Line)); end; end if; if Synth.Debugger.Flag_Need_Debug then Synth.Debugger.Debug_Break (C.Inst, Stmt); end if; case Get_Kind (Stmt) is when Iir_Kind_If_Statement => Synth_If_Statement (C, Stmt); when Iir_Kind_Simple_Signal_Assignment_Statement => Synth_Simple_Signal_Assignment (C.Inst, Stmt); when Iir_Kind_Conditional_Signal_Assignment_Statement => Synth_Conditional_Signal_Assignment (C.Inst, Stmt); when Iir_Kind_Variable_Assignment_Statement => Synth_Variable_Assignment (C, Stmt); when Iir_Kind_Conditional_Variable_Assignment_Statement => Synth_Conditional_Variable_Assignment (C, Stmt); when Iir_Kind_Case_Statement => Synth_Case_Statement (C, Stmt); when Iir_Kind_For_Loop_Statement => if Is_Dyn then Synth_Dynamic_For_Loop_Statement (C, Stmt); else Synth_Static_For_Loop_Statement (C, Stmt); end if; when Iir_Kind_While_Loop_Statement => if Is_Dyn then Synth_Dynamic_While_Loop_Statement (C, Stmt); else Synth_Static_While_Loop_Statement (C, Stmt); end if; when Iir_Kind_Null_Statement => -- Easy null; when Iir_Kind_Return_Statement => Synth_Return_Statement (C, Stmt); when Iir_Kind_Procedure_Call_Statement => Synth_Procedure_Call (C.Inst, Stmt); when Iir_Kind_Report_Statement => if not Is_Dyn then Synth_Static_Report_Statement (C, Stmt); end if; when Iir_Kind_Assertion_Statement => if not Is_Dyn then Synth_Static_Assertion_Statement (C, Stmt); else Synth_Dynamic_Assertion_Statement (C, Stmt); end if; when Iir_Kind_Exit_Statement | Iir_Kind_Next_Statement => if Is_Dyn then Synth_Dynamic_Exit_Next_Statement (C, Stmt); else Synth_Static_Exit_Next_Statement (C, Stmt); end if; when others => Error_Kind ("synth_sequential_statements", Stmt); end case; if Is_Dyn then if Has_Phi then Pop_Phi (Phi_T); Push_Phi; Pop_Phi (Phi_F); Merge_Phis (Ctxt, Get_Current_Value (Ctxt, C.W_En), Phi_T, Phi_F, Stmt); end if; if Is_Static_Bit0 (C.W_En) then -- Not more execution. return; end if; else if not C.S_En or C.Nbr_Ret /= 0 then return; end if; end if; Stmt := Get_Chain (Stmt); end loop; end Synth_Sequential_Statements; Proc_Pool : aliased Areapools.Areapool; -- Synthesis of statements of a non-sensitized process. procedure Synth_Process_Sequential_Statements (C : in out Seq_Context; Proc : Node) is Ctxt : constant Context_Acc := Get_Build (C.Inst); Stmt : Node; Cond : Node; Cond_Val : Valtyp; Phi_True : Phi_Type; Phi_False : Phi_Type; begin Stmt := Get_Sequential_Statement_Chain (Proc); -- The first statement must be a wait statement. if Get_Kind (Stmt) /= Iir_Kind_Wait_Statement then Error_Msg_Synth (+Stmt, "expect wait as the first statement"); return; end if; -- Handle the condition as an if. Cond := Get_Condition_Clause (Stmt); if Cond = Null_Node then Error_Msg_Synth (+Stmt, "expect wait condition"); return; end if; Cond_Val := Synth_Expression (C.Inst, Cond); Push_Phi; Synth_Sequential_Statements (C, Get_Chain (Stmt)); Pop_Phi (Phi_True); Push_Phi; Pop_Phi (Phi_False); Merge_Phis (Ctxt, Get_Net (Ctxt, Cond_Val), Phi_True, Phi_False, Stmt); end Synth_Process_Sequential_Statements; procedure Synth_Process_Statement (Syn_Inst : Synth_Instance_Acc; Proc : Node) is use Areapools; Label : constant Name_Id := Get_Identifier (Proc); Decls_Chain : constant Node := Get_Declaration_Chain (Proc); Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; Ctxt : constant Context_Acc := Get_Build (Syn_Inst); M : Areapools.Mark_Type; C_Sname : Sname; C : Seq_Context (Mode_Dynamic); begin if Label = Null_Identifier then C_Sname := New_Internal_Name (Ctxt, Get_Sname (Syn_Inst)); else C_Sname := New_Sname_User (Label, Get_Sname (Syn_Inst)); end if; C := (Mode => Mode_Dynamic, Inst => Make_Instance (Syn_Inst, Proc, C_Sname), Cur_Loop => null, W_En => Alloc_Wire (Wire_Variable, Bit_Type, Proc), W_Ret => No_Wire_Id, W_Val => No_Wire_Id, Ret_Init => No_Net, Ret_Value => No_Valtyp, Ret_Typ => null, Nbr_Ret => 0); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; Push_Phi; Synth_Declarations (C.Inst, Decls_Chain); Set_Wire_Gate (C.W_En, Build_Control_Signal (Syn_Inst, 1, Proc)); Phi_Assign_Static (C.W_En, Bit1); if not Is_Error (C.Inst) then case Iir_Kinds_Process_Statement (Get_Kind (Proc)) is when Iir_Kind_Sensitized_Process_Statement => Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Proc)); -- FIXME: check sensitivity list. when Iir_Kind_Process_Statement => Synth_Process_Sequential_Statements (C, Proc); end case; end if; Pop_And_Merge_Phi (Ctxt, Proc); Finalize_Declarations (C.Inst, Decls_Chain); Free_Instance (C.Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; Finalize_Assignment (Ctxt, C.W_En); Free_Wire (C.W_En); end Synth_Process_Statement; function Synth_User_Function_Call (Syn_Inst : Synth_Instance_Acc; Expr : Node) return Valtyp is begin -- Is it a call to an ieee function ? declare Imp : constant Node := Get_Implementation (Expr); Pkg : constant Node := Get_Parent (Imp); Unit : Node; Lib : Node; begin if Get_Kind (Pkg) = Iir_Kind_Package_Declaration and then not Is_Uninstantiated_Package (Pkg) then Unit := Get_Parent (Pkg); if Get_Kind (Unit) = Iir_Kind_Design_Unit then Lib := Get_Library (Get_Design_File (Unit)); if Get_Identifier (Lib) = Std_Names.Name_Ieee then Error_Msg_Synth (+Expr, "unhandled call to ieee function %i", +Imp); Set_Error (Syn_Inst); return No_Valtyp; end if; end if; end if; end; return Synth_Subprogram_Call (Syn_Inst, Expr); end Synth_User_Function_Call; procedure Synth_Concurrent_Assertion_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Cond : constant Node := Get_Assertion_Condition (Stmt); Val : Valtyp; Inst : Instance; begin Val := Synth_Expression (Syn_Inst, Cond); if Val = No_Valtyp then Set_Error (Syn_Inst); return; end if; if Is_Static (Val.Val) then if Read_Discrete (Val) /= 1 then Synth_Static_Report (Syn_Inst, Stmt); end if; return; end if; if not Flags.Flag_Formal then -- Ignore the net. return; end if; Inst := Build_Assert (Ctxt, Synth_Label (Syn_Inst, Stmt), Get_Net (Ctxt, Val)); Set_Location (Inst, Get_Location (Stmt)); end Synth_Concurrent_Assertion_Statement; procedure Synth_Block_Statement (Syn_Inst : Synth_Instance_Acc; Blk : Node) is use Areapools; Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; Blk_Inst : Synth_Instance_Acc; Blk_Sname : Sname; M : Areapools.Mark_Type; begin -- No support for guard or header. if Get_Block_Header (Blk) /= Null_Node or else Get_Guard_Decl (Blk) /= Null_Node then raise Internal_Error; end if; Apply_Block_Configuration (Get_Block_Block_Configuration (Blk), Blk); Blk_Sname := New_Sname_User (Get_Identifier (Blk), Get_Sname (Syn_Inst)); Blk_Inst := Make_Instance (Syn_Inst, Blk, Blk_Sname); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; Synth_Declarations (Blk_Inst, Get_Declaration_Chain (Blk)); Synth_Concurrent_Statements (Blk_Inst, Get_Concurrent_Statement_Chain (Blk)); Finalize_Declarations (Blk_Inst, Get_Declaration_Chain (Blk)); Free_Instance (Blk_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Block_Statement; function Synth_Psl_NFA (Syn_Inst : Synth_Instance_Acc; NFA : PSL.Types.PSL_NFA; Nbr_States : Int32; States : Net; Loc : Source.Syn_Src) return Net is use PSL.NFAs; Ctxt : constant Context_Acc := Get_Build (Syn_Inst); S : NFA_State; S_Num : Int32; D_Num : Int32; I : Net; Cond : Net; E : NFA_Edge; D_Arr : Net_Array_Acc; Res : Net; begin D_Arr := new Net_Array'(0 .. Nbr_States - 1 => No_Net); -- For each state: S := Get_First_State (NFA); while S /= No_State loop S_Num := Get_State_Label (S); I := Build_Extract_Bit (Ctxt, States, Uns32 (S_Num)); Set_Location (I, Loc); -- For each edge: E := Get_First_Src_Edge (S); while E /= No_Edge loop -- Edge condition. Cond := Build_Dyadic (Ctxt, Id_And, I, Synth_PSL_Expression (Syn_Inst, Get_Edge_Expr (E))); Set_Location (Cond, Loc); -- TODO: if EOS is present, then this is a live state. -- Reverse order for final concatenation. D_Num := Nbr_States - 1 - Get_State_Label (Get_Edge_Dest (E)); if D_Arr (D_Num) /= No_Net then Cond := Build_Dyadic (Ctxt, Id_Or, D_Arr (D_Num), Cond); Set_Location (Cond, Loc); end if; D_Arr (D_Num) := Cond; E := Get_Next_Src_Edge (E); end loop; S := Get_Next_State (S); end loop; if D_Arr (Nbr_States - 1) = No_Net then D_Arr (Nbr_States - 1) := Build_Const_UB32 (Ctxt, 0, 1); end if; Concat_Array (Ctxt, D_Arr.all, Res); Free_Net_Array (D_Arr); return Res; end Synth_Psl_NFA; procedure Synth_Psl_Dff (Syn_Inst : Synth_Instance_Acc; Stmt : Node; Next_States : out Net) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Nbr_States : constant Int32 := Get_PSL_Nbr_States (Stmt); States : Net; Init : Net; Clk : Net; Clk_Inst : Instance; begin -- create init net, clock net Init := Build_Const_UB32 (Ctxt, 1, Uns32 (Nbr_States)); Set_Location (Init, Stmt); Clk := Synth_PSL_Expression (Syn_Inst, Get_PSL_Clock (Stmt)); -- Check the clock is an edge and extract it. Clk_Inst := Get_Net_Parent (Clk); if Get_Id (Clk_Inst) not in Edge_Module_Id then Error_Msg_Synth (+Stmt, "clock is not an edge"); Next_States := No_Net; return; end if; -- build idff States := Build_Idff (Ctxt, Clk, No_Net, Init); Set_Location (States, Stmt); -- create update nets -- For each state: if set, evaluate all outgoing edges. Next_States := Synth_Psl_NFA (Syn_Inst, Get_PSL_NFA (Stmt), Nbr_States, States, Stmt); Connect (Get_Input (Get_Net_Parent (States), 1), Next_States); end Synth_Psl_Dff; function Synth_Psl_Final (Syn_Inst : Synth_Instance_Acc; Stmt : Node; Next_States : Net) return Net is use PSL.Types; use PSL.NFAs; NFA : constant PSL_NFA := Get_PSL_NFA (Stmt); Res : Net; begin Res := Build_Extract_Bit (Get_Build (Syn_Inst), Next_States, Uns32 (Get_State_Label (Get_Final_State (NFA)))); Set_Location (Res, Stmt); return Res; end Synth_Psl_Final; function Synth_Psl_Not_Final (Syn_Inst : Synth_Instance_Acc; Stmt : Node; Next_States : Net) return Net is Res : Net; begin Res := Build_Monadic (Get_Build (Syn_Inst), Id_Not, Synth_Psl_Final (Syn_Inst, Stmt, Next_States)); Set_Location (Res, Stmt); return Res; end Synth_Psl_Not_Final; procedure Synth_Psl_Restrict_Directive (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Next_States : Net; Res : Net; Inst : Instance; begin if not Flags.Flag_Formal then return; end if; -- Build assume gate. -- Note: for synthesis, we assume the next state will be correct. -- (If we assume on States, then the first cycle is ignored). Synth_Psl_Dff (Syn_Inst, Stmt, Next_States); if Next_States /= No_Net then -- The restriction holds as long as there is a 1 in the NFA state. Res := Build_Reduce (Ctxt, Id_Red_Or, Next_States); Set_Location (Res, Stmt); Inst := Build_Assume (Ctxt, Synth_Label (Syn_Inst, Stmt), Res); Set_Location (Inst, Get_Location (Stmt)); end if; end Synth_Psl_Restrict_Directive; procedure Synth_Psl_Cover_Directive (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Next_States : Net; Res : Net; Inst : Instance; begin if not Flags.Flag_Formal then return; end if; -- Build cover gate. -- Note: for synthesis, we assume the next state will be correct. -- (If we assume on States, then the first cycle is ignored). Synth_Psl_Dff (Syn_Inst, Stmt, Next_States); if Next_States /= No_Net then -- The sequence is covered as soon as the final state is reached. Res := Synth_Psl_Final (Syn_Inst, Stmt, Next_States); Inst := Build_Cover (Get_Build (Syn_Inst), Synth_Label (Syn_Inst, Stmt), Res); Set_Location (Inst, Get_Location (Stmt)); end if; end Synth_Psl_Cover_Directive; procedure Synth_Psl_Assume_Directive (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Next_States : Net; Inst : Instance; begin if not Flags.Flag_Formal then return; end if; -- Build assume gate. -- Note: for synthesis, we assume the next state will be correct. -- (If we assume on States, then the first cycle is ignored). Synth_Psl_Dff (Syn_Inst, Stmt, Next_States); if Next_States /= No_Net then Inst := Build_Assume (Ctxt, Synth_Label (Syn_Inst, Stmt), Synth_Psl_Not_Final (Syn_Inst, Stmt, Next_States)); Set_Location (Inst, Get_Location (Stmt)); end if; end Synth_Psl_Assume_Directive; procedure Synth_Psl_Assert_Directive (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is use PSL.Types; use PSL.NFAs; Ctxt : constant Context_Acc := Get_Build (Syn_Inst); NFA : constant PSL_NFA := Get_PSL_NFA (Stmt); Active : NFA_State; Next_States : Net; Inst : Instance; Lab : Sname; begin if not Flags.Flag_Formal then return; end if; -- Build assert gate. -- Note: for synthesis, we assume the next state will be correct. -- (If we assert on States, then the first cycle is ignored). Synth_Psl_Dff (Syn_Inst, Stmt, Next_States); if Next_States = No_Net then return; end if; Lab := Synth_Label (Syn_Inst, Stmt); Inst := Build_Assert (Ctxt, Lab, Synth_Psl_Not_Final (Syn_Inst, Stmt, Next_States)); Set_Location (Inst, Get_Location (Stmt)); -- Also add a cover gate to cover assertion activation. if Flags.Flag_Assert_Cover then Active := Get_Active_State (NFA); if Active /= No_State then if Lab /= No_Sname then Lab := New_Sname_User (Std_Names.Name_Cover, Lab); end if; Inst := Build_Assert_Cover (Get_Build (Syn_Inst), Lab, Build_Extract_Bit (Get_Build (Syn_Inst), Next_States, Uns32 (Get_State_Label (Active)))); Set_Location (Inst, Get_Location (Stmt)); end if; end if; end Synth_Psl_Assert_Directive; procedure Synth_Generate_Statement_Body (Syn_Inst : Synth_Instance_Acc; Bod : Node; Name : Sname; Iterator : Node := Null_Node; Iterator_Val : Valtyp := No_Valtyp) is use Areapools; Decls_Chain : constant Node := Get_Declaration_Chain (Bod); Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; Bod_Inst : Synth_Instance_Acc; M : Areapools.Mark_Type; begin Bod_Inst := Make_Instance (Syn_Inst, Bod, Name); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; if Iterator /= Null_Node then -- Add the iterator (for for-generate). Create_Object (Bod_Inst, Iterator, Iterator_Val); end if; Synth_Declarations (Bod_Inst, Decls_Chain); Synth_Concurrent_Statements (Bod_Inst, Get_Concurrent_Statement_Chain (Bod)); Finalize_Declarations (Bod_Inst, Decls_Chain); Free_Instance (Bod_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Generate_Statement_Body; procedure Synth_If_Generate_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Gen : Node; Bod : Node; Icond : Node; Cond : Valtyp; Name : Sname; begin Gen := Stmt; Name := New_Sname_User (Get_Identifier (Stmt), Get_Sname (Syn_Inst)); loop Icond := Get_Condition (Gen); if Icond /= Null_Node then Cond := Synth_Expression (Syn_Inst, Icond); Strip_Const (Cond); else -- It is the else generate. Cond := No_Valtyp; end if; if Cond = No_Valtyp or else Read_Discrete (Cond) = 1 then Bod := Get_Generate_Statement_Body (Gen); Apply_Block_Configuration (Get_Generate_Block_Configuration (Bod), Bod); Synth_Generate_Statement_Body (Syn_Inst, Bod, Name); exit; end if; Gen := Get_Generate_Else_Clause (Gen); exit when Gen = Null_Node; end loop; end Synth_If_Generate_Statement; procedure Synth_For_Generate_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Iterator : constant Node := Get_Parameter_Specification (Stmt); Bod : constant Node := Get_Generate_Statement_Body (Stmt); Configs : constant Node := Get_Generate_Block_Configuration (Bod); It_Type : constant Node := Get_Declaration_Type (Iterator); Config : Node; It_Rng : Type_Acc; Val : Valtyp; Name : Sname; Lname : Sname; begin if It_Type /= Null_Node then Synth_Subtype_Indication (Syn_Inst, It_Type); end if; -- Initial value. It_Rng := Get_Subtype_Object (Syn_Inst, Get_Type (Iterator)); Val := Create_Value_Discrete (It_Rng.Drange.Left, It_Rng); Name := New_Sname_User (Get_Identifier (Stmt), Get_Sname (Syn_Inst)); while In_Range (It_Rng.Drange, Read_Discrete (Val)) loop -- Find and apply the config block. declare Spec : Node; begin Config := Configs; while Config /= Null_Node loop Spec := Get_Block_Specification (Config); case Get_Kind (Spec) is when Iir_Kind_Simple_Name => exit; when others => Error_Kind ("synth_for_generate_statement", Spec); end case; Config := Get_Prev_Block_Configuration (Config); end loop; if Config = Null_Node then raise Internal_Error; end if; Apply_Block_Configuration (Config, Bod); end; -- FIXME: get position ? Lname := New_Sname_Version (Uns32 (Read_Discrete (Val)), Name); Synth_Generate_Statement_Body (Syn_Inst, Bod, Lname, Iterator, Val); Update_Index (It_Rng.Drange, Val); end loop; end Synth_For_Generate_Statement; procedure Synth_Concurrent_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); begin case Get_Kind (Stmt) is when Iir_Kind_Concurrent_Simple_Signal_Assignment => Push_Phi; Synth_Simple_Signal_Assignment (Syn_Inst, Stmt); Pop_And_Merge_Phi (Ctxt, Stmt); when Iir_Kind_Concurrent_Conditional_Signal_Assignment => Push_Phi; Synth_Conditional_Signal_Assignment (Syn_Inst, Stmt); Pop_And_Merge_Phi (Ctxt, Stmt); when Iir_Kind_Concurrent_Selected_Signal_Assignment => Push_Phi; Synth_Selected_Signal_Assignment (Syn_Inst, Stmt); Pop_And_Merge_Phi (Ctxt, Stmt); when Iir_Kind_Concurrent_Procedure_Call_Statement => Push_Phi; Synth_Procedure_Call (Syn_Inst, Stmt); Pop_And_Merge_Phi (Ctxt, Stmt); when Iir_Kinds_Process_Statement => Synth_Process_Statement (Syn_Inst, Stmt); when Iir_Kind_If_Generate_Statement => Synth_If_Generate_Statement (Syn_Inst, Stmt); when Iir_Kind_For_Generate_Statement => Synth_For_Generate_Statement (Syn_Inst, Stmt); when Iir_Kind_Component_Instantiation_Statement => if Is_Component_Instantiation (Stmt) then declare Comp_Config : constant Node := Get_Component_Configuration (Stmt); begin if Get_Binding_Indication (Comp_Config) = Null_Node then -- Not bound. Synth_Blackbox_Instantiation_Statement (Syn_Inst, Stmt); else Synth_Component_Instantiation_Statement (Syn_Inst, Stmt); end if; end; -- Un-apply configuration. Set_Component_Configuration (Stmt, Null_Node); else Synth_Design_Instantiation_Statement (Syn_Inst, Stmt); end if; when Iir_Kind_Block_Statement => Synth_Block_Statement (Syn_Inst, Stmt); when Iir_Kind_Psl_Default_Clock => null; when Iir_Kind_Psl_Restrict_Directive => Synth_Psl_Restrict_Directive (Syn_Inst, Stmt); when Iir_Kind_Psl_Assume_Directive => if Flags.Flag_Assume_As_Assert then Synth_Psl_Assert_Directive (Syn_Inst, Stmt); else Synth_Psl_Assume_Directive (Syn_Inst, Stmt); end if; when Iir_Kind_Psl_Cover_Directive => Synth_Psl_Cover_Directive (Syn_Inst, Stmt); when Iir_Kind_Psl_Assert_Directive => if Flags.Flag_Assert_As_Assume then Synth_Psl_Assume_Directive (Syn_Inst, Stmt); else Synth_Psl_Assert_Directive (Syn_Inst, Stmt); end if; when Iir_Kind_Concurrent_Assertion_Statement => -- Passive statement. Synth_Concurrent_Assertion_Statement (Syn_Inst, Stmt); when others => Error_Kind ("synth_concurrent_statement", Stmt); end case; end Synth_Concurrent_Statement; procedure Synth_Concurrent_Statements (Syn_Inst : Synth_Instance_Acc; Stmts : Node) is Stmt : Node; begin Stmt := Stmts; while Is_Valid (Stmt) loop Synth_Concurrent_Statement (Syn_Inst, Stmt); Stmt := Get_Chain (Stmt); end loop; end Synth_Concurrent_Statements; -- For allconst/allseq/... procedure Synth_Attribute_Formal (Syn_Inst : Synth_Instance_Acc; Val : Node; Id : Formal_Module_Id) is Spec : constant Node := Get_Attribute_Specification (Val); Sig : constant Node := Get_Designated_Entity (Val); V : Valtyp; begin -- The type must be boolean if (Get_Base_Type (Get_Type (Val)) /= Vhdl.Std_Package.Boolean_Type_Definition) then Error_Msg_Synth (+Val, "type of attribute %i must be boolean", (1 => +Get_Attribute_Designator (Spec))); return; end if; -- The designated entity must be a signal. if Get_Kind (Sig) /= Iir_Kind_Signal_Declaration then Error_Msg_Synth (+Val, "attribute %i only applies to signals", (1 => +Get_Attribute_Designator (Spec))); return; end if; -- The value must be true V := Synth_Expression_With_Type (Syn_Inst, Get_Expression (Spec), Boolean_Type); if Read_Discrete (V) /= 1 then return; end if; declare Off : Value_Offsets; Dyn : Dyn_Name; N : Net; Base : Valtyp; Typ : Type_Acc; begin Synth_Assignment_Prefix (Syn_Inst, Sig, Base, Typ, Off, Dyn); pragma Assert (Off = (0, 0)); pragma Assert (Dyn.Voff = No_Net); pragma Assert (Base.Val.Kind = Value_Wire); pragma Assert (Base.Typ = Typ); N := Build_Formal_Input (Get_Build (Syn_Inst), Id, Typ.W); Set_Location (N, Val); Add_Conc_Assign (Base.Val.W, N, 0, Val); end; end Synth_Attribute_Formal; procedure Synth_Attribute_Values (Syn_Inst : Synth_Instance_Acc; Unit : Node) is use Std_Names; Val : Node; Spec : Node; Id : Name_Id; begin Val := Get_Attribute_Value_Chain (Unit); while Val /= Null_Node loop Spec := Get_Attribute_Specification (Val); Id := Get_Identifier (Get_Attribute_Designator (Spec)); case Id is when Name_Allconst => Synth_Attribute_Formal (Syn_Inst, Val, Id_Allconst); when Name_Allseq => Synth_Attribute_Formal (Syn_Inst, Val, Id_Allseq); when Name_Anyconst => Synth_Attribute_Formal (Syn_Inst, Val, Id_Anyconst); when Name_Anyseq => Synth_Attribute_Formal (Syn_Inst, Val, Id_Anyseq); when others => Warning_Msg_Synth (+Spec, "unhandled attribute %i", (1 => +Id)); end case; Val := Get_Value_Chain (Val); end loop; end Synth_Attribute_Values; procedure Synth_Verification_Unit (Syn_Inst : Synth_Instance_Acc; Unit : Node) is use Areapools; Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; Unit_Inst : Synth_Instance_Acc; Unit_Sname : Sname; M : Areapools.Mark_Type; Item : Node; Last_Type : Node; begin Unit_Sname := New_Sname_User (Get_Identifier (Unit), Get_Sname (Syn_Inst)); Unit_Inst := Make_Instance (Syn_Inst, Unit, Unit_Sname); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; Apply_Block_Configuration (Get_Verification_Block_Configuration (Unit), Unit); Last_Type := Null_Node; Item := Get_Vunit_Item_Chain (Unit); while Item /= Null_Node loop case Get_Kind (Item) is when Iir_Kind_Psl_Default_Clock => null; when Iir_Kind_Psl_Assert_Directive => Synth_Psl_Assert_Directive (Unit_Inst, Item); when Iir_Kind_Psl_Assume_Directive => Synth_Psl_Assume_Directive (Unit_Inst, Item); when Iir_Kind_Psl_Restrict_Directive => Synth_Psl_Restrict_Directive (Unit_Inst, Item); when Iir_Kind_Psl_Cover_Directive => Synth_Psl_Cover_Directive (Unit_Inst, Item); when Iir_Kind_Signal_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body | Iir_Kind_Attribute_Declaration | Iir_Kind_Attribute_Specification => Synth_Declaration (Unit_Inst, Item, False, Last_Type); when Iir_Kinds_Concurrent_Signal_Assignment | Iir_Kinds_Process_Statement | Iir_Kinds_Generate_Statement | Iir_Kind_Block_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Component_Instantiation_Statement => Synth_Concurrent_Statement (Unit_Inst, Item); when others => Error_Kind ("synth_verification_unit", Item); end case; Item := Get_Chain (Item); end loop; Synth_Attribute_Values (Unit_Inst, Unit); -- Finalize Item := Get_Vunit_Item_Chain (Unit); while Item /= Null_Node loop case Get_Kind (Item) is when Iir_Kind_Psl_Default_Clock | Iir_Kind_Psl_Assert_Directive | Iir_Kind_Psl_Assume_Directive | Iir_Kind_Psl_Restrict_Directive | Iir_Kind_Psl_Cover_Directive => null; when Iir_Kinds_Concurrent_Signal_Assignment | Iir_Kinds_Process_Statement | Iir_Kinds_Generate_Statement | Iir_Kind_Block_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Component_Instantiation_Statement => null; when Iir_Kind_Signal_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body | Iir_Kind_Attribute_Declaration | Iir_Kind_Attribute_Specification => Finalize_Declaration (Unit_Inst, Item, False); when others => Error_Kind ("synth_verification_unit(2)", Item); end case; Item := Get_Chain (Item); end loop; Free_Instance (Unit_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Verification_Unit; end Synth.Stmts;