synth: finalize concurrent assignments (WIP).

6 files changed, 342 insertions, 33 deletions

diff --git a/src/synth/synth-environment.adb b/src/synth/synth-environment.adb
index ce8bb6983..3443a741a 100644
--- a/src/synth/synth-environment.adb
+++ b/src/synth/synth-environment.adb
@@ -18,10 +18,14 @@
 --  Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston,
 --  MA 02110-1301, USA.
 
+with Netlists.Builders; use Netlists.Builders;
 with Netlists.Utils; use Netlists.Utils;
 with Netlists.Gates; use Netlists.Gates;
-with Netlists.Builders; use Netlists.Builders;
+with Errorout; use Errorout;
 with Synth.Inference;
+with Synth.Errors; use Synth.Errors;
+with Vhdl.Nodes;
+with Vhdl.Errors; use Vhdl.Errors;
 
 package body Synth.Environment is
    procedure Set_Wire_Mark (Wid : Wire_Id; Mark : Boolean := True) is
@@ -41,7 +45,9 @@ package body Synth.Environment is
                              Mark_Flag => False,
                              Decl => Obj,
                              Gate => No_Net,
-                             Cur_Assign => No_Seq_Assign));
+                             Cur_Assign => No_Seq_Assign,
+                             Final_Assign => No_Conc_Assign,
+                             Nbr_Final_Assign => 0));
       return Wire_Id_Table.Last;
    end Alloc_Wire;
 
@@ -105,9 +111,62 @@ package body Synth.Environment is
       end loop;
    end Pop_Phi;
 
+   function Get_Conc_Offset (Asgn : Conc_Assign) return Uns32 is
+   begin
+      return Conc_Assign_Table.Table (Asgn).Offset;
+   end Get_Conc_Offset;
+
+   function Get_Conc_Value (Asgn : Conc_Assign) return Net is
+   begin
+      return Conc_Assign_Table.Table (Asgn).Value;
+   end Get_Conc_Value;
+
+   function Get_Conc_Chain (Asgn : Conc_Assign) return Conc_Assign is
+   begin
+      return Conc_Assign_Table.Table (Asgn).Next;
+   end Get_Conc_Chain;
+
+   procedure Set_Conc_Chain (Asgn : Conc_Assign; Chain : Conc_Assign) is
+   begin
+      Conc_Assign_Table.Table (Asgn).Next := Chain;
+   end Set_Conc_Chain;
+
+   procedure Add_Conc_Assign
+     (Wire_Rec : in out Wire_Id_Record; Val : Net; Stmt : Source.Syn_Src)
+   is
+      Inst : constant Instance := Get_Parent (Val);
+      V : Net;
+      Off : Uns32;
+      Inp : Input;
+   begin
+      --  Check for partial assignment.
+      if Get_Id (Inst) = Id_Insert
+        and then Get_Input_Net (Inst, 0) = Wire_Rec.Gate
+      then
+         --  TODO: handle multiple partial assignments
+         --    (like o (1) <= x; o (3) <= y;)
+         --  TODO: handle dyn assignment (like o (i) <= x;)
+         Inp := Get_Input (Inst, 1);
+         V := Get_Driver (Inp);
+         Off := Get_Param_Uns32 (Inst, 0);
+         Disconnect (Inp);
+         Free_Instance (Inst);
+      else
+         V := Val;
+         Off := 0;
+      end if;
+      Conc_Assign_Table.Append ((Next => Wire_Rec.Final_Assign,
+                                 Value => V,
+                                 Offset => Off,
+                                 Stmt => Stmt));
+      Wire_Rec.Final_Assign := Conc_Assign_Table.Last;
+      Wire_Rec.Nbr_Final_Assign := Wire_Rec.Nbr_Final_Assign + 1;
+   end Add_Conc_Assign;
+
    --  This procedure is called after each concurrent statement to assign
    --  values to signals.
-   procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc)
+   procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc;
+                                Stmt : Source.Syn_Src)
    is
       Phi : Phi_Type;
       Asgn : Seq_Assign;
@@ -118,42 +177,31 @@ package body Synth.Environment is
       while Asgn /= No_Seq_Assign loop
          declare
             Asgn_Rec : Seq_Assign_Record renames Assign_Table.Table (Asgn);
-            Outport : constant Net := Wire_Id_Table.Table (Asgn_Rec.Id).Gate;
+            Wid : constant Wire_Id := Asgn_Rec.Id;
+            Wire_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid);
+            Outport : constant Net := Wire_Rec.Gate;
             --  Must be connected to an Id_Output or Id_Signal
             pragma Assert (Outport /= No_Net);
             Gate_Inst : Instance;
             Gate_In : Input;
             Drv : Net;
-            New_Sig : Net;
          begin
             Gate_Inst := Get_Parent (Outport);
             Gate_In := Get_Input (Gate_Inst, 0);
             Drv := Get_Driver (Gate_In);
 
-            case Wire_Id_Table.Table (Asgn_Rec.Id).Kind is
+            case Wire_Rec.Kind is
                when Wire_Output
                  | Wire_Signal
                  | Wire_Variable =>
                   if Drv /= No_Net then
                      --  Output already assigned
                      raise Internal_Error;
-                  else
-                     Drv := Inference.Infere (Ctxt, Asgn_Rec.Value, Outport);
-
-                     if Get_Id (Gate_Inst) = Id_Isignal
-                       and then Get_Driver (Get_Input (Gate_Inst, 1)) = No_Net
-                     then
-                        --  Mutate Isignal to signal.
-                        New_Sig := Build_Signal
-                          (Ctxt, Get_Name (Gate_Inst), Get_Width (Outport));
-                        Connect (Get_Input (Get_Parent (New_Sig), 0), Drv);
-                        Redirect_Inputs (Outport, New_Sig);
-                        Wire_Id_Table.Table (Asgn_Rec.Id).Gate := New_Sig;
-                        Free_Instance (Gate_Inst);
-                     else
-                        Connect (Gate_In, Drv);
-                     end if;
                   end if;
+
+                  Drv := Inference.Infere (Ctxt, Asgn_Rec.Value, Outport);
+
+                  Add_Conc_Assign (Wire_Rec, Drv, Stmt);
                when others =>
                   raise Internal_Error;
             end case;
@@ -164,6 +212,201 @@ package body Synth.Environment is
       --  FIXME: free wires.
    end Pop_And_Merge_Phi;
 
+   --  Merge sort of conc_assign by offset.
+   procedure Sort_Conc_Assign (Chain : Conc_Assign;
+                               Len : Natural;
+                               First : out Conc_Assign;
+                               Next : out Conc_Assign)
+   is
+      Left, Right : Conc_Assign;
+      Last : Conc_Assign;
+      El : Conc_Assign;
+   begin
+      if Len = 0 then
+         First := No_Conc_Assign;
+         Next := Chain;
+      elsif Len = 1 then
+         First := Chain;
+         Next := Get_Conc_Chain (Chain);
+         Set_Conc_Chain (Chain, No_Conc_Assign);
+      else
+         --  Divide.
+         Sort_Conc_Assign (Chain, Len / 2, Left, Right);
+         Sort_Conc_Assign (Right, Len - Len / 2, Right, Next);
+
+         First := No_Conc_Assign;
+         Last := No_Conc_Assign;
+         for I in 1 .. Len loop
+            if Left /= No_Conc_Assign
+              and then
+              (Right = No_Conc_Assign
+                 or else Get_Conc_Offset (Left) <= Get_Conc_Offset (Right))
+            then
+               El := Left;
+               Left := Get_Conc_Chain (Left);
+            else
+               pragma Assert (Right /= No_Conc_Assign);
+               El := Right;
+               Right := Get_Conc_Chain (Right);
+            end if;
+            --  Append
+            if First = No_Conc_Assign then
+               First := El;
+            else
+               Set_Conc_Chain (Last, El);
+            end if;
+            Last := El;
+         end loop;
+         Set_Conc_Chain (Last, No_Conc_Assign);
+      end if;
+   end Sort_Conc_Assign;
+
+   procedure Finalize_Complex_Assignment (Ctxt : Builders.Context_Acc;
+                                          Wire_Rec : Wire_Id_Record;
+                                          Value : out Net)
+   is
+      First_Assign : Conc_Assign;
+      Asgn : Conc_Assign;
+      Last_Asgn : Conc_Assign;
+      New_Asgn : Conc_Assign;
+      Next_Off : Uns32;
+      Expected_Off : Uns32;
+      Last_Off : Uns32;
+      Nbr_Assign : Natural;
+   begin
+      Nbr_Assign := Wire_Rec.Nbr_Final_Assign;
+      --  Sort assignments by offset.
+      Asgn := Wire_Rec.Final_Assign;
+      Sort_Conc_Assign (Asgn, Nbr_Assign, Asgn, Last_Asgn);
+      First_Assign := Asgn;
+
+      --  Report overlaps and holes, count number of inputs
+      Last_Asgn := No_Conc_Assign;
+      Expected_Off := 0;
+      Last_Off := Get_Width (Wire_Rec.Gate);
+      while Expected_Off < Last_Off loop
+         if Asgn /= No_Conc_Assign then
+            Next_Off := Get_Conc_Offset (Asgn);
+         else
+            Next_Off := Last_Off;
+         end if;
+         if Next_Off = Expected_Off then
+            --  Normal case.
+            pragma Assert (Asgn /= No_Conc_Assign);
+            Expected_Off := Expected_Off + Get_Width (Get_Conc_Value (Asgn));
+            Last_Asgn := Asgn;
+            Asgn := Get_Conc_Chain (Asgn);
+         elsif Next_Off > Expected_Off then
+            if Next_Off = Expected_Off + 1 then
+               Warning_Msg_Synth
+                 (+Wire_Rec.Decl, "no assignment for offset %v",
+                  (1 => +Expected_Off));
+            else
+               Warning_Msg_Synth
+                 (+Wire_Rec.Decl, "no assignment for offsets %v:%v",
+                  (+Expected_Off, +(Next_Off - 1)));
+            end if;
+
+            --  Insert conc_assign with initial value.
+            --  FIXME: handle initial values.
+            Conc_Assign_Table.Append
+              ((Next => Asgn,
+                Value => Build_Const_Z (Ctxt, Next_Off - Expected_Off),
+                Offset => Expected_Off,
+                Stmt => Source.No_Syn_Src));
+            New_Asgn := Conc_Assign_Table.Last;
+            if Last_Asgn = No_Conc_Assign then
+               First_Assign := New_Asgn;
+            else
+               Set_Conc_Chain (Last_Asgn, New_Asgn);
+            end if;
+            Last_Asgn := New_Asgn;
+            Nbr_Assign := Nbr_Assign + 1;
+
+            Expected_Off := Next_Off;
+         else
+            pragma Assert (Next_Off < Expected_Off);
+            Error_Msg_Synth
+              (+Wire_Rec.Decl, "multiple assignments for offsets %v:%v",
+               (+Next_Off, +(Expected_Off - 1)));
+            --  TODO: insert resolver
+            pragma Assert (Asgn /= No_Conc_Assign);
+            Last_Asgn := Asgn;
+            Asgn := Get_Conc_Chain (Asgn);
+         end if;
+      end loop;
+
+      --  Create concat
+      --  Set concat inputs
+      if Nbr_Assign = 1 then
+         Value := Get_Conc_Value (First_Assign);
+      elsif Nbr_Assign = 2 then
+         Value := Build_Concat2 (Ctxt,
+                                 Get_Conc_Value (Last_Asgn),
+                                 Get_Conc_Value (First_Assign));
+      else
+         raise Internal_Error;
+      end if;
+   end Finalize_Complex_Assignment;
+
+   procedure Finalize_Assignment
+     (Ctxt : Builders.Context_Acc; Wire_Rec : Wire_Id_Record)
+   is
+      use Vhdl.Nodes;
+      Gate_Inst : constant Instance := Get_Parent (Wire_Rec.Gate);
+      Inp : constant Input := Get_Input (Gate_Inst, 0);
+      Value : Net;
+   begin
+      case Wire_Rec.Nbr_Final_Assign is
+         when 0 =>
+            --  TODO: use initial value ?
+            if Wire_Rec.Decl /= Null_Node
+              and then Wire_Rec.Kind = Wire_Output
+            then
+               Error_Msg_Synth
+                 (+Wire_Rec.Decl, "no assignment for %n", +Wire_Rec.Decl);
+            end if;
+            return;
+         when 1 =>
+            declare
+               Conc_Asgn : Conc_Assign_Record renames
+                 Conc_Assign_Table.Table (Wire_Rec.Final_Assign);
+            begin
+               if Conc_Asgn.Offset = 0
+                 and then (Get_Width (Conc_Asgn.Value)
+                             = Get_Width (Wire_Rec.Gate))
+               then
+                  --  Single and full assignment.
+                  Value := Conc_Asgn.Value;
+               else
+                  --  Partial or multiple assignments.
+                  Finalize_Complex_Assignment (Ctxt, Wire_Rec, Value);
+               end if;
+            end;
+         when others =>
+            Finalize_Complex_Assignment (Ctxt, Wire_Rec, Value);
+      end case;
+
+      Connect (Inp, Value);
+   end Finalize_Assignment;
+
+   procedure Finalize_Assignments (Ctxt : Builders.Context_Acc) is
+   begin
+      pragma Assert (Phis_Table.Last = No_Phi_Id);
+      --  pragma Assert (Assign_Table.Last = No_Seq_Assign);
+
+      for Wid in Wire_Id_Table.First + 1 .. Wire_Id_Table.Last loop
+         declare
+            Wire_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid);
+         begin
+            pragma Assert (Wire_Rec.Cur_Assign = No_Seq_Assign);
+            Finalize_Assignment (Ctxt, Wire_Rec);
+         end;
+      end loop;
+
+      Wire_Id_Table.Set_Last (No_Wire_Id);
+   end Finalize_Assignments;
+
    --  Sort the LEN first wires of chain W (linked by Chain) in Id increasing
    --  values.  The result is assigned to FIRST and the first non-sorted wire
    --  (the one after LEN) is assigned to NEXT.  The chain headed by FIRST
@@ -360,7 +603,9 @@ begin
                           Mark_Flag => False,
                           Decl => Source.No_Syn_Src,
                           Gate => No_Net,
-                          Cur_Assign => No_Seq_Assign));
+                          Cur_Assign => No_Seq_Assign,
+                          Final_Assign => No_Conc_Assign,
+                          Nbr_Final_Assign => 0));
    pragma Assert (Wire_Id_Table.Last = No_Wire_Id);
 
    Assign_Table.Append ((Phi => No_Phi_Id,
@@ -373,4 +618,10 @@ begin
    Phis_Table.Append ((First => No_Seq_Assign,
                        Nbr => 0));
    pragma Assert (Phis_Table.Last = No_Phi_Id);
+
+   Conc_Assign_Table.Append ((Next => No_Conc_Assign,
+                              Value => No_Net,
+                              Offset => 0,
+                              Stmt => Source.No_Syn_Src));
+   pragma Assert (Conc_Assign_Table.Last = No_Conc_Assign);
 end Synth.Environment;
diff --git a/src/synth/synth-environment.ads b/src/synth/synth-environment.ads
index 4338aebbf..0cdddc08f 100644
--- a/src/synth/synth-environment.ads
+++ b/src/synth/synth-environment.ads
@@ -90,7 +90,8 @@ package Synth.Environment is
 
    --  Destroy the current phi context and merge it.  Can apply only for the
    --  first non-top level phi context.
-   procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc);
+   procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc;
+                                Stmt : Source.Syn_Src);
 
    --  Handle if statement.  According to SEL, the value of the wires are
    --  those from T or from F.
@@ -108,6 +109,7 @@ package Synth.Environment is
    function Current_Phi return Phi_Id;
    pragma Inline (Current_Phi);
 
+   procedure Finalize_Assignments (Ctxt : Builders.Context_Acc);
 private
    type Wire_Id is new Uns32;
    No_Wire_Id : constant Wire_Id := 0;
@@ -140,6 +142,12 @@ private
 
       --  Current assignment (if there is one).
       Cur_Assign : Seq_Assign;
+
+      --  Chain of concurrent assigns for this wire.
+      --  This is used to detect multiple collision and to handle partial
+      --  assignments.
+      Final_Assign : Conc_Assign;
+      Nbr_Final_Assign : Natural;
    end record;
 
    type Seq_Assign_Record is record
@@ -159,6 +167,17 @@ private
       Value : Net;
    end record;
 
+   type Conc_Assign_Record is record
+      Next : Conc_Assign;
+
+      --  Concurrent assignment at OFFSET.  The width is set by value width.
+      Value : Net;
+      Offset : Uns32;
+
+      --  Source of the assignment.  Useful to report errors.
+      Stmt : Source.Syn_Src;
+   end record;
+
    type Phi_Type is record
       First : Seq_Assign;
       Nbr : Uns32;
@@ -181,4 +200,10 @@ private
       Table_Index_Type => Seq_Assign,
       Table_Low_Bound => No_Seq_Assign,
       Table_Initial => 1024);
+
+   package Conc_Assign_Table is new Tables
+     (Table_Component_Type => Conc_Assign_Record,
+      Table_Index_Type => Conc_Assign,
+      Table_Low_Bound => No_Conc_Assign,
+      Table_Initial => 1024);
 end Synth.Environment;
diff --git a/src/synth/synth-errors.adb b/src/synth/synth-errors.adb
index a8e4c04c7..be4ed43c9 100644
--- a/src/synth/synth-errors.adb
+++ b/src/synth/synth-errors.adb
@@ -28,9 +28,26 @@ package body Synth.Errors is
    end Error_Msg_Synth;
 
    procedure Error_Msg_Synth (Loc : Location_Type;
-                              Msg : String) is
+                              Msg : String;
+                              Args : Earg_Arr := No_Eargs) is
    begin
       Report_Msg (Msgid_Error, Errorout.Elaboration,
-                  +Loc, Msg, (1 .. 0 => <>));
+                  +Loc, Msg, Args);
    end Error_Msg_Synth;
+
+   procedure Warning_Msg_Synth (Loc : Location_Type;
+                                Msg : String;
+                                Arg1 : Earg_Type) is
+   begin
+      Report_Msg (Msgid_Warning, Errorout.Elaboration,
+                  +Loc, Msg, (1 => Arg1));
+   end Warning_Msg_Synth;
+
+   procedure Warning_Msg_Synth (Loc : Location_Type;
+                                Msg : String;
+                                Args : Earg_Arr := No_Eargs) is
+   begin
+      Report_Msg (Msgid_Warning, Errorout.Elaboration, +Loc, Msg, Args);
+   end Warning_Msg_Synth;
+
 end Synth.Errors;
diff --git a/src/synth/synth-errors.ads b/src/synth/synth-errors.ads
index ccc48d375..b6b5885c4 100644
--- a/src/synth/synth-errors.ads
+++ b/src/synth/synth-errors.ads
@@ -26,5 +26,12 @@ package Synth.Errors is
                               Msg : String;
                               Arg1 : Earg_Type);
    procedure Error_Msg_Synth (Loc : Location_Type;
-                              Msg : String);
+                              Msg : String;
+                              Args : Earg_Arr := No_Eargs);
+   procedure Warning_Msg_Synth (Loc : Location_Type;
+                                Msg : String;
+                                Arg1 : Earg_Type);
+   procedure Warning_Msg_Synth (Loc : Location_Type;
+                                Msg : String;
+                                Args : Earg_Arr := No_Eargs);
 end Synth.Errors;
diff --git a/src/synth/synth-insts.adb b/src/synth/synth-insts.adb
index d5d3f4bf3..f1ff14348 100644
--- a/src/synth/synth-insts.adb
+++ b/src/synth/synth-insts.adb
@@ -630,7 +630,7 @@ package body Synth.Insts is
                Make_Object (Syn_Inst, Wire_None, Inter);
             when Port_Out
               | Port_Inout =>
-               Make_Object (Syn_Inst, Wire_Output, Inter);
+               Make_Object (Syn_Inst, Wire_None, Inter);
          end case;
          Inter := Get_Chain (Inter);
       end loop;
@@ -778,7 +778,6 @@ package body Synth.Insts is
       pragma Assert (Get_Kind (Inst.Config) = Iir_Kind_Block_Configuration);
       Apply_Block_Configuration (Inst.Config, Arch);
 
-
       Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Entity));
       Synth_Concurrent_Statements
         (Syn_Inst, Get_Concurrent_Statement_Chain (Entity));
@@ -787,6 +786,8 @@ package body Synth.Insts is
       Synth_Concurrent_Statements
         (Syn_Inst, Get_Concurrent_Statement_Chain (Arch));
 
+      Finalize_Assignments (Build_Context);
+
       --  Remove unused gates.  This is not only an optimization but also
       --  a correctness point: there might be some unsynthesizable gates, like
       --  the one created for 'rising_egde (clk) and not rst'.
diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-stmts.adb
index 993a64491..83a163d60 100644
--- a/src/synth/synth-stmts.adb
+++ b/src/synth/synth-stmts.adb
@@ -1210,14 +1210,19 @@ package body Synth.Stmts is
    begin
       Stmt := Stmts;
       while Is_Valid (Stmt) loop
-         Push_Phi;
          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 (Build_Context, Stmt);
             when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+               Push_Phi;
                Synth_Conditional_Signal_Assignment (Syn_Inst, Stmt);
+               Pop_And_Merge_Phi (Build_Context, Stmt);
             when Iir_Kinds_Process_Statement =>
+               Push_Phi;
                Synth_Process_Statement (Syn_Inst, Stmt);
+               Pop_And_Merge_Phi (Build_Context, Stmt);
             when Iir_Kind_If_Generate_Statement =>
                declare
                   Gen : Node;
@@ -1237,9 +1242,8 @@ package body Synth.Stmts is
                      exit when Gen = Null_Node;
                   end loop;
                end;
-            when Iir_Kind_Concurrent_Assertion_Statement =>
-               Synth_Concurrent_Assertion_Statement (Syn_Inst, Stmt);
             when Iir_Kind_Component_Instantiation_Statement =>
+               Push_Phi;
                if Is_Component_Instantiation (Stmt) then
                   declare
                      Comp_Config : constant Node :=
@@ -1257,14 +1261,18 @@ package body Synth.Stmts is
                else
                   Synth_Design_Instantiation_Statement (Syn_Inst, Stmt);
                end if;
+               Pop_And_Merge_Phi (Build_Context, Stmt);
             when Iir_Kind_Psl_Default_Clock =>
                null;
             when Iir_Kind_Psl_Restrict_Directive =>
+               --  Passive statement.
                Synth_Psl_Restrict_Directive (Syn_Inst, Stmt);
+            when Iir_Kind_Concurrent_Assertion_Statement =>
+               --  Passive statement.
+               Synth_Concurrent_Assertion_Statement (Syn_Inst, Stmt);
             when others =>
                Error_Kind ("synth_statements", Stmt);
          end case;
-         Pop_And_Merge_Phi (Build_Context);
          Stmt := Get_Chain (Stmt);
       end loop;
    end Synth_Concurrent_Statements;