diff options
Diffstat (limited to 'src/synth/synth-vhdl_context.adb')
| -rw-r--r-- | src/synth/synth-vhdl_context.adb | 562 |
1 files changed, 562 insertions, 0 deletions
diff --git a/src/synth/synth-vhdl_context.adb b/src/synth/synth-vhdl_context.adb new file mode 100644 index 000000000..2a497ae0f --- /dev/null +++ b/src/synth/synth-vhdl_context.adb @@ -0,0 +1,562 @@ +-- Synthesis context. +-- 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 <gnu.org/licenses>. + +with Ada.Unchecked_Deallocation; + +with Name_Table; use Name_Table; +with Types_Utils; use Types_Utils; + +with Vhdl.Errors; use Vhdl.Errors; +with Vhdl.Utils; + +with Netlists.Folds; use Netlists.Folds; + +with Synth.Expr; use Synth.Expr; +with Netlists.Locations; + +package body Synth.Vhdl_Context is + function Make_Base_Instance return Synth_Instance_Acc + is + Base : Base_Instance_Acc; + Top_Module : Module; + Res : Synth_Instance_Acc; + Ctxt : Context_Acc; + begin + Top_Module := + New_Design (New_Sname_Artificial (Get_Identifier ("top"), No_Sname)); + Ctxt := Build_Builders (Top_Module); + + Base := new Base_Instance_Type'(Builder => Ctxt, + Top_Module => Top_Module, + Cur_Module => No_Module); + + Res := new Synth_Instance_Type'(Max_Objs => Global_Info.Nbr_Objects, + Is_Const => False, + Is_Error => False, + Base => Base, + Name => No_Sname, + Block_Scope => Global_Info, + Up_Block => null, + Uninst_Scope => null, + Source_Scope => Null_Node, + Elab_Objects => 0, + Objects => (others => + (Kind => Obj_None))); + return Res; + end Make_Base_Instance; + + procedure Free_Base_Instance is + begin + -- TODO: really free. + null; + end Free_Base_Instance; + + function Make_Instance (Parent : Synth_Instance_Acc; + Blk : Node; + Name : Sname := No_Sname) + return Synth_Instance_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Blk); + Scope : Sim_Info_Acc; + Res : Synth_Instance_Acc; + begin + if Get_Kind (Blk) = Iir_Kind_Architecture_Body then + -- Architectures are extensions of entities. + Scope := Get_Info (Vhdl.Utils.Get_Entity (Blk)); + else + Scope := Info; + end if; + + Res := new Synth_Instance_Type'(Max_Objs => Info.Nbr_Objects, + Is_Const => False, + Is_Error => False, + Base => Parent.Base, + Name => Name, + Block_Scope => Scope, + Up_Block => Parent, + Uninst_Scope => null, + Source_Scope => Blk, + Elab_Objects => 0, + Objects => (others => + (Kind => Obj_None))); + return Res; + end Make_Instance; + + procedure Set_Instance_Base (Inst : Synth_Instance_Acc; + Base : Synth_Instance_Acc) is + begin + Inst.Base := Base.Base; + end Set_Instance_Base; + + procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc) + is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Synth_Instance_Type, Synth_Instance_Acc); + begin + Deallocate (Synth_Inst); + end Free_Instance; + + procedure Set_Instance_Module (Inst : Synth_Instance_Acc; M : Module) + is + Prev_Base : constant Base_Instance_Acc := Inst.Base; + Base : Base_Instance_Acc; + Self_Inst : Instance; + begin + Base := new Base_Instance_Type'(Builder => Prev_Base.Builder, + Top_Module => Prev_Base.Top_Module, + Cur_Module => M); + Builders.Set_Parent (Base.Builder, M); + + Self_Inst := Create_Self_Instance (M); + pragma Unreferenced (Self_Inst); + + Inst.Base := Base; + end Set_Instance_Module; + + function Is_Error (Inst : Synth_Instance_Acc) return Boolean is + begin + return Inst.Is_Error; + end Is_Error; + + procedure Set_Error (Inst : Synth_Instance_Acc) is + begin + Inst.Is_Error := True; + end Set_Error; + + function Get_Instance_Module (Inst : Synth_Instance_Acc) return Module is + begin + return Inst.Base.Cur_Module; + end Get_Instance_Module; + + function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node is + begin + return Inst.Source_Scope; + end Get_Source_Scope; + + function Get_Top_Module (Inst : Synth_Instance_Acc) return Module is + begin + return Inst.Base.Top_Module; + end Get_Top_Module; + + function Get_Sname (Inst : Synth_Instance_Acc) return Sname is + begin + return Inst.Name; + end Get_Sname; + + function Get_Build (Inst : Synth_Instance_Acc) + return Netlists.Builders.Context_Acc is + begin + return Inst.Base.Builder; + end Get_Build; + + function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean is + begin + return Inst.Is_Const; + end Get_Instance_Const; + + function Check_Set_Instance_Const (Inst : Synth_Instance_Acc) + return Boolean is + begin + for I in 1 .. Inst.Elab_Objects loop + if Inst.Objects (I).Kind /= Obj_Subtype then + return False; + end if; + end loop; + return True; + end Check_Set_Instance_Const; + + procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean) is + begin + pragma Assert (not Val or else Check_Set_Instance_Const (Inst)); + Inst.Is_Const := Val; + end Set_Instance_Const; + + procedure Create_Object (Syn_Inst : Synth_Instance_Acc; + Slot : Object_Slot_Type; + Num : Object_Slot_Type := 1) is + begin + -- Check elaboration order. + -- Note: this is not done for package since objects from package are + -- commons (same scope), and package annotation order can be different + -- from package elaboration order (eg: body). + if Slot /= Syn_Inst.Elab_Objects + 1 + or else Syn_Inst.Objects (Slot).Kind /= Obj_None + then + Error_Msg_Elab ("synth: bad elaboration order of objects"); + raise Internal_Error; + end if; + Syn_Inst.Elab_Objects := Slot + Num - 1; + end Create_Object; + + procedure Create_Object_Force + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + pragma Assert + (Syn_Inst.Objects (Info.Slot).Kind = Obj_None + or else Vt = (null, null) + or else Syn_Inst.Objects (Info.Slot) = (Kind => Obj_Object, + Obj => No_Valtyp)); + Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt); + end Create_Object_Force; + + procedure Create_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Create_Object (Syn_Inst, Info.Slot, 1); + Create_Object_Force (Syn_Inst, Decl, Vt); + end Create_Object; + + procedure Create_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc) + is + pragma Assert (Typ /= null); + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Create_Object (Syn_Inst, Info.Slot, 1); + pragma Assert (Syn_Inst.Objects (Info.Slot).Kind = Obj_None); + Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Subtype, T_Typ => Typ); + end Create_Subtype_Object; + + procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc; + Is_Global : Boolean) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + if Is_Global then + pragma Assert (Syn_Inst.Objects (Info.Pkg_Slot).Kind = Obj_None); + pragma Assert (Syn_Inst.Up_Block = null); + null; + else + pragma Assert (Syn_Inst.Up_Block /= null); + Create_Object (Syn_Inst, Info.Slot, 1); + end if; + Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, + I_Inst => Inst); + end Create_Package_Object; + + procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + pragma Assert (Syn_Inst.Up_Block /= null); + Create_Object (Syn_Inst, Info.Pkg_Slot, 1); + Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, + I_Inst => Inst); + end Create_Package_Interface; + + function Get_Package_Object + (Syn_Inst : Synth_Instance_Acc; Info : Sim_Info_Acc) + return Synth_Instance_Acc + is + Parent : Synth_Instance_Acc; + begin + Parent := Get_Instance_By_Scope (Syn_Inst, Info.Pkg_Parent); + return Parent.Objects (Info.Pkg_Slot).I_Inst; + end Get_Package_Object; + + function Get_Package_Object + (Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc is + begin + return Get_Package_Object (Syn_Inst, Get_Info (Pkg)); + end Get_Package_Object; + + procedure Set_Uninstantiated_Scope + (Syn_Inst : Synth_Instance_Acc; Bod : Node) is + begin + Syn_Inst.Uninst_Scope := Get_Info (Bod); + end Set_Uninstantiated_Scope; + + procedure Destroy_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Slot : constant Object_Slot_Type := Info.Slot; + begin + if Slot /= Syn_Inst.Elab_Objects + or else Info.Obj_Scope /= Syn_Inst.Block_Scope + then + Error_Msg_Elab ("synth: bad destroy order"); + end if; + Syn_Inst.Objects (Slot) := (Kind => Obj_None); + Syn_Inst.Elab_Objects := Slot - 1; + end Destroy_Object; + + procedure Create_Wire_Object (Syn_Inst : Synth_Instance_Acc; + Kind : Wire_Kind; + Obj : Node) + is + Obj_Type : constant Node := Get_Type (Obj); + Otyp : constant Type_Acc := Get_Subtype_Object (Syn_Inst, Obj_Type); + Val : Valtyp; + Wid : Wire_Id; + begin + if Kind = Wire_None then + Wid := No_Wire_Id; + else + Wid := Alloc_Wire (Kind, Otyp, Obj); + end if; + Val := Create_Value_Wire (Wid, Otyp); + + Create_Object (Syn_Inst, Obj, Val); + end Create_Wire_Object; + + function Get_Instance_By_Scope + (Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc) + return Synth_Instance_Acc is + begin + case Scope.Kind is + when Kind_Block + | Kind_Frame + | Kind_Process => + declare + Current : Synth_Instance_Acc; + begin + Current := Syn_Inst; + while Current /= null loop + if Current.Block_Scope = Scope then + return Current; + end if; + Current := Current.Up_Block; + end loop; + raise Internal_Error; + end; + when Kind_Package => + if Scope.Pkg_Parent = null then + -- This is a scope for an uninstantiated package. + declare + Current : Synth_Instance_Acc; + begin + Current := Syn_Inst; + while Current /= null loop + if Current.Uninst_Scope = Scope then + return Current; + end if; + Current := Current.Up_Block; + end loop; + raise Internal_Error; + end; + else + -- Instantiated package. + return Get_Package_Object (Syn_Inst, Scope); + end if; + when others => + raise Internal_Error; + end case; + end Get_Instance_By_Scope; + + function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc + is + Parent : Node; + begin + Parent := Get_Parent (Blk); + if Get_Kind (Parent) = Iir_Kind_Architecture_Body then + Parent := Vhdl.Utils.Get_Entity (Parent); + end if; + return Get_Info (Parent); + end Get_Parent_Scope; + + function Get_Value (Syn_Inst: Synth_Instance_Acc; Obj : Node) + return Valtyp + is + Info : constant Sim_Info_Acc := Get_Info (Obj); + Obj_Inst : Synth_Instance_Acc; + begin + Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); + return Obj_Inst.Objects (Info.Slot).Obj; + end Get_Value; + + function Get_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Obj_Inst : Synth_Instance_Acc; + begin + Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); + return Obj_Inst.Objects (Info.Slot).T_Typ; + end Get_Subtype_Object; + + -- Set Is_0 to True iff VEC is 000... + -- Set Is_X to True iff VEC is XXX... + procedure Is_Full (Vec : Logvec_Array; + Is_0 : out Boolean; + Is_X : out Boolean; + Is_Z : out Boolean) + is + Val : Uns32; + Zx : Uns32; + begin + Val := Vec (0).Val; + Zx := Vec (0).Zx; + Is_0 := False; + Is_X := False; + Is_Z := False; + if Val = 0 and Zx = 0 then + Is_0 := True; + elsif Zx = not 0 then + if Val = not 0 then + Is_X := True; + elsif Val = 0 then + Is_Z := True; + else + return; + end if; + else + return; + end if; + + for I in 1 .. Vec'Last loop + if Vec (I).Val /= Val or else Vec (I).Zx /= Zx then + -- Clear flags. + Is_0 := False; + Is_X := False; + Is_Z := False; + return; + end if; + end loop; + end Is_Full; + + procedure Value2net (Ctxt : Context_Acc; + Val : Memtyp; + Off : Uns32; + W : Width; + Vec : in out Logvec_Array; + Res : out Net) + is + Vec_Off : Uns32; + Has_Zx : Boolean; + Inst : Instance; + Is_0, Is_X, Is_Z : Boolean; + begin + -- First convert to logvec. + Has_Zx := False; + Vec_Off := 0; + Value2logvec (Val, Off, W, Vec, Vec_Off, Has_Zx); + pragma Assert (Vec_Off = W); + + -- Then convert logvec to net. + if W = 0 then + -- For null range (like the null string literal "") + Res := Build_Const_UB32 (Ctxt, 0, 0); + elsif W <= 32 then + -- 32 bit result. + if not Has_Zx then + Res := Build_Const_UB32 (Ctxt, Vec (0).Val, W); + elsif Vec (0).Val = 0 and then Sext (Vec (0).Zx, Natural (W)) = not 0 + then + Res := Build_Const_Z (Ctxt, W); + else + Res := Build_Const_UL32 (Ctxt, Vec (0).Val, Vec (0).Zx, W); + end if; + return; + else + Is_Full (Vec, Is_0, Is_X, Is_Z); + if Is_0 then + Res := Build_Const_UB32 (Ctxt, 0, W); + elsif Is_X then + Res := Build_Const_X (Ctxt, W); + elsif Is_Z then + Res := Build_Const_Z (Ctxt, W); + elsif not Has_Zx then + Inst := Build_Const_Bit (Ctxt, W); + for I in Vec'Range loop + Set_Param_Uns32 (Inst, Param_Idx (I), Vec (I).Val); + end loop; + Res := Get_Output (Inst, 0); + else + Inst := Build_Const_Log (Ctxt, W); + for I in Vec'Range loop + Set_Param_Uns32 (Inst, Param_Idx (2 * I), Vec (I).Val); + Set_Param_Uns32 (Inst, Param_Idx (2 * I + 1), Vec (I).Zx); + end loop; + Res := Get_Output (Inst, 0); + end if; + end if; + end Value2net; + + function Get_Partial_Memtyp_Net + (Ctxt : Context_Acc; Val : Memtyp; Off : Uns32; Wd : Width) return Net + is + Nd : constant Digit_Index := Digit_Index ((Wd + 31) / 32); + Res : Net; + begin + if Nd > 64 then + declare + Vecp : Logvec_Array_Acc; + begin + Vecp := new Logvec_Array'(0 .. Nd - 1 => (0, 0)); + Value2net (Ctxt, Val, Off, Wd, Vecp.all, Res); + Free_Logvec_Array (Vecp); + return Res; + end; + else + declare + Vec : Logvec_Array (0 .. Nd - 1) := (others => (0, 0)); + begin + Value2net (Ctxt, Val, Off, Wd, Vec, Res); + return Res; + end; + end if; + end Get_Partial_Memtyp_Net; + + function Get_Memtyp_Net (Ctxt : Context_Acc; Val : Memtyp) return Net is + begin + return Get_Partial_Memtyp_Net (Ctxt, Val, 0, Val.Typ.W); + end Get_Memtyp_Net; + + function Get_Net (Ctxt : Context_Acc; Val : Valtyp) return Net is + begin + case Val.Val.Kind is + when Value_Wire => + return Get_Current_Value (Ctxt, Val.Val.W); + when Value_Net => + return Val.Val.N; + when Value_Alias => + declare + Res : Net; + begin + if Val.Val.A_Obj.Kind = Value_Wire then + Res := Get_Current_Value (Ctxt, Val.Val.A_Obj.W); + return Build2_Extract + (Ctxt, Res, Val.Val.A_Off.Net_Off, Val.Typ.W); + else + pragma Assert (Val.Val.A_Off.Net_Off = 0); + return Get_Net (Ctxt, (Val.Typ, Val.Val.A_Obj)); + end if; + end; + when Value_Const => + if Val.Val.C_Net = No_Net then + Val.Val.C_Net := Get_Net (Ctxt, (Val.Typ, Val.Val.C_Val)); + Locations.Set_Location (Get_Net_Parent (Val.Val.C_Net), + Get_Location (Val.Val.C_Loc)); + end if; + return Val.Val.C_Net; + when Value_Memory => + return Get_Memtyp_Net (Ctxt, Get_Memtyp (Val)); + when others => + raise Internal_Error; + end case; + end Get_Net; +end Synth.Vhdl_Context; |