synth: rename synth-context to synth-vhdl_context

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;