path: root/src/synth/synth-aggr.adb

--  Aggregates synthesis.
--  Copyright (C) 2020 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, write to the Free Software
--  Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston,
--  MA 02110-1301, USA.

with Types; use Types;
with Str_Table;

with Netlists; use Netlists;
with Netlists.Utils; use Netlists.Utils;
with Netlists.Builders; use Netlists.Builders;

with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Utils; use Vhdl.Utils;

with Synth.Errors; use Synth.Errors;
with Synth.Expr; use Synth.Expr;
with Synth.Stmts; use Synth.Stmts;
with Synth.Decls; use Synth.Decls;

package body Synth.Aggr is
   type Stride_Array is array (Dim_Type range <>) of Nat32;

   procedure Get_Index_Offset (Index : Int64;
                               Bounds : Bound_Type;
                               Expr : Iir;
                               Off : out Uns32;
                               Err_P : out Boolean)
   is
      Left : constant Int64 := Int64 (Bounds.Left);
      Right : constant Int64 := Int64 (Bounds.Right);
   begin
      case Bounds.Dir is
         when Dir_To =>
            if Index >= Left and then Index <= Right then
               -- to
               Off := Uns32 (Index - Left);
               Err_P := False;
               return;
            end if;
         when Dir_Downto =>
            if Index <= Left and then Index >= Right then
               -- downto
               Off := Uns32 (Left - Index);
               Err_P := False;
               return;
            end if;
      end case;
      Error_Msg_Synth (+Expr, "index out of bounds");
      Off := 0;
      Err_P := True;
   end Get_Index_Offset;

   procedure Get_Index_Offset (Index : Valtyp;
                               Bounds : Bound_Type;
                               Expr : Iir;
                               Off : out Uns32;
                               Err_P : out Boolean) is
   begin
      Get_Index_Offset (Read_Discrete (Index), Bounds, Expr, Off, Err_P);
   end Get_Index_Offset;

   function Fill_Stride (Typ : Type_Acc) return Stride_Array is
   begin
      case Typ.Kind is
         when Type_Vector =>
            return (1 => 1);
         when Type_Array =>
            declare
               Bnds : constant Bound_Array_Acc := Typ.Abounds;
               Res : Stride_Array (1 .. Bnds.Ndim);
               Stride : Nat32;
            begin
               Stride := 1;
               for I in reverse 2 .. Bnds.Ndim loop
                  Res (Dim_Type (I)) := Stride;
                  Stride := Stride * Nat32 (Bnds.D (I).Len);
               end loop;
               Res (1) := Stride;
               return Res;
            end;
         when others =>
            raise Internal_Error;
      end case;
   end Fill_Stride;

   procedure Fill_Array_Aggregate (Syn_Inst : Synth_Instance_Acc;
                                   Aggr : Node;
                                   Res : Valtyp_Array_Acc;
                                   Typ : Type_Acc;
                                   First_Pos : Nat32;
                                   Strides : Stride_Array;
                                   Dim : Dim_Type;
                                   Const_P : out Boolean;
                                   Err_P : out boolean)
   is
      Ctxt : constant Context_Acc := Get_Build (Syn_Inst);
      Bound : constant Bound_Type := Get_Array_Bound (Typ, Dim);
      El_Typ : constant Type_Acc := Get_Array_Element (Typ);
      Stride : constant Nat32 := Strides (Dim);
      Value : Node;
      Assoc : Node;
      Nbr_Els : Nat32;
      Sub_Err : Boolean;

      procedure Set_Elem (Pos : Nat32)
      is
         Sub_Const : Boolean;
         Sub_Err : Boolean;
         Val : Valtyp;
      begin
         Nbr_Els := Nbr_Els + 1;

         if Dim = Strides'Last then
            Val := Synth_Expression_With_Type (Syn_Inst, Value, El_Typ);
            Val := Synth_Subtype_Conversion (Ctxt, Val, El_Typ, False, Value);
            pragma Assert (Res (Pos) = No_Valtyp);
            Res (Pos) := Val;
            if Val = No_Valtyp then
               Err_P := True;
            else
               if Const_P and then not Is_Static (Val.Val) then
                  Const_P := False;
               end if;
            end if;
         else
            Fill_Array_Aggregate
              (Syn_Inst, Value, Res, Typ, Pos, Strides, Dim + 1,
               Sub_Const, Sub_Err);
            Const_P := Const_P and Sub_Const;
            Err_P := Err_P or Sub_Err;
         end if;
      end Set_Elem;

      procedure Set_Vector (Pos : Nat32; Len : Nat32; Val : Valtyp) is
      begin
         pragma Assert (Dim = Strides'Last);
         if Len = 0 then
            return;
         end if;
         pragma Assert (Res (Pos) = No_Valtyp);
         Res (Pos) := Val;

         --  Mark following slots as busy so that 'others => x' won't fill
         --  them.
         for I in 2 .. Len loop
            Res (Pos + I - 1).Typ := Val.Typ;
         end loop;

         Nbr_Els := Nbr_Els + Len;
         if Const_P and then not Is_Static (Val.Val) then
            Const_P := False;
         end if;
      end Set_Vector;

      Pos : Nat32;
   begin
      Pos := First_Pos;
      Nbr_Els := 0;
      Const_P := True;
      Err_P := False;

      if Get_Kind (Aggr) = Iir_Kind_String_Literal8 then
         declare
            Str_Id  : constant String8_Id := Get_String8_Id (Aggr);
            Str_Len : constant Int32 := Get_String_Length (Aggr);
            E       : Valtyp;
            V       : Nat8;
         begin
            pragma Assert (Stride = 1);
            if Bound.Len /= Width (Str_Len) then
               Error_Msg_Synth
                 (+Aggr, "string length doesn't match bound length");
               Err_P := True;
            end if;
            for I in 1 .. Pos32'Min (Pos32 (Str_Len), Pos32 (Bound.Len)) loop
               E := Create_Value_Memory (El_Typ);
               V := Str_Table.Element_String8 (Str_Id, I);
               Write_U8 (E.Val.Mem, Nat8'Pos (V));
               Res (Pos) := E;
               Pos := Pos + 1;
            end loop;
            return;
         end;
      end if;

      Assoc := Get_Association_Choices_Chain (Aggr);
      while Is_Valid (Assoc) loop
         Value := Get_Associated_Expr (Assoc);
         loop
            case Get_Kind (Assoc) is
               when Iir_Kind_Choice_By_None =>
                  if Get_Element_Type_Flag (Assoc) then
                     if Pos >= First_Pos + Stride * Nat32 (Bound.Len) then
                        Error_Msg_Synth (+Assoc, "element out of array bound");
                     else
                        Set_Elem (Pos);
                        Pos := Pos + Stride;
                     end if;
                  else
                     declare
                        Val : Valtyp;
                        Val_Len : Uns32;
                     begin
                        Val := Synth_Expression_With_Basetype
                          (Syn_Inst, Value);
                        Val_Len := Get_Bound_Length (Val.Typ, 1);
                        pragma Assert (Stride = 1);
                        if Pos - First_Pos > Nat32 (Bound.Len - Val_Len) then
                           Error_Msg_Synth
                             (+Assoc, "element out of array bound");
                        else
                           Set_Vector (Pos, Nat32 (Val_Len), Val);
                           Pos := Pos + Nat32 (Val_Len);
                        end if;
                     end;
                  end if;
               when Iir_Kind_Choice_By_Others =>
                  pragma Assert (Get_Element_Type_Flag (Assoc));
                  declare
                     Last_Pos : constant Nat32 :=
                       First_Pos + Nat32 (Bound.Len) * Stride;
                  begin
                     while Pos < Last_Pos loop
                        if Res (Pos) = No_Valtyp then
                           --  FIXME: the check is not correct if there is
                           --   an array.
                           Set_Elem (Pos);
                        end if;
                        Pos := Pos + Stride;
                     end loop;
                  end;
               when Iir_Kind_Choice_By_Expression =>
                  pragma Assert (Get_Element_Type_Flag (Assoc));
                  declare
                     Ch : constant Node := Get_Choice_Expression (Assoc);
                     Idx : Valtyp;
                     Off : Uns32;
                  begin
                     Idx := Synth_Expression (Syn_Inst, Ch);
                     if not Is_Static (Idx.Val) then
                        Error_Msg_Synth (+Ch, "choice is not static");
                     else
                        Get_Index_Offset (Idx, Bound, Ch, Off, Sub_Err);
                        Err_P := Err_P or Sub_Err;
                        exit when Err_P;
                        Set_Elem (First_Pos + Nat32 (Off) * Stride);
                     end if;
                  end;
               when Iir_Kind_Choice_By_Range =>
                  declare
                     Ch : constant Node := Get_Choice_Range (Assoc);
                     Rng : Discrete_Range_Type;
                     Val : Valtyp;
                     Rng_Len : Width;
                     Off : Uns32;
                  begin
                     Synth_Discrete_Range (Syn_Inst, Ch, Rng);
                     if Get_Element_Type_Flag (Assoc) then
                        Val := Create_Value_Discrete
                          (Rng.Left,
                           Get_Subtype_Object (Syn_Inst,
                                               Get_Base_Type (Get_Type (Ch))));
                        while In_Range (Rng, Read_Discrete (Val)) loop
                           Get_Index_Offset (Val, Bound, Ch, Off, Sub_Err);
                           Err_P := Err_P or Sub_Err;
                           exit when Err_P;
                           Set_Elem (First_Pos + Nat32 (Off) * Stride);
                           Update_Index (Rng, Val);
                           exit when Err_P;
                        end loop;
                     else
                        --  The direction must be the same.
                        if Rng.Dir /= Bound.Dir then
                           Error_Msg_Synth
                             (+Assoc, "direction of range does not match "
                                & "direction of array");
                        end if;
                        --  FIXME: can the expression be unbounded ?
                        Val := Synth_Expression_With_Basetype
                          (Syn_Inst, Value);
                        --  The length must match the range.
                        Rng_Len := Get_Range_Length (Rng);
                        if Get_Bound_Length (Val.Typ, 1) /= Rng_Len then
                           Error_Msg_Synth
                             (+Value, "length doesn't match range");
                        end if;
                        pragma Assert (Stride = 1);
                        Get_Index_Offset (Rng.Left, Bound, Ch, Off, Sub_Err);
                        Err_P := Err_P or Sub_Err;
                        exit when Err_P;
                        Set_Vector
                          (First_Pos + Nat32 (Off), Nat32 (Rng_Len), Val);
                     end if;
                  end;
               when others =>
                  Error_Msg_Synth
                    (+Assoc, "unhandled association form");
            end case;
            Assoc := Get_Chain (Assoc);
            exit when Is_Null (Assoc);
            exit when not Get_Same_Alternative_Flag (Assoc);
            exit when Err_P;
         end loop;
      end loop;

      if not Err_P and then Nbr_Els /= Nat32 (Bound.Len) then
         Error_Msg_Synth (+Aggr, "aggregate length doesn't match its bound");
         Err_P := True;
      end if;
   end Fill_Array_Aggregate;

   procedure Fill_Record_Aggregate (Syn_Inst : Synth_Instance_Acc;
                                    Aggr : Node;
                                    Aggr_Typ : Type_Acc;
                                    Rec : Valtyp_Array_Acc;
                                    Err_P : out Boolean;
                                    Const_P : out Boolean)
   is
      Ctxt : constant Context_Acc := Get_Build (Syn_Inst);
      Value : Node;
      Assoc : Node;
      Pos : Nat32;

      --  POS is the element position, from 0 to nbr el - 1.
      procedure Set_Elem (Pos : Nat32)
      is
         Val : Valtyp;
         El_Type : Type_Acc;
      begin
         El_Type := Aggr_Typ.Rec.E (Iir_Index32 (Pos + 1)).Typ;
         Val := Synth_Expression_With_Type (Syn_Inst, Value, El_Type);
         if Const_P and not Is_Static (Val.Val) then
            Const_P := False;
         end if;
         Val := Synth_Subtype_Conversion (Ctxt, Val, El_Type, False, Value);
         if Val = No_Valtyp then
            Err_P := True;
            return;
         end if;
         --  Put in reverse order.  The first record element (at position 0)
         --  will be the LSB, so the last element of REC.
         Rec (Nat32 (Rec'Last - Pos)) := Val;
      end Set_Elem;
   begin
      Assoc := Get_Association_Choices_Chain (Aggr);
      Pos := 0;
      Const_P := True;
      Err_P := False;
      while Is_Valid (Assoc) loop
         Value := Get_Associated_Expr (Assoc);
         loop
            case Get_Kind (Assoc) is
               when Iir_Kind_Choice_By_None =>
                  Set_Elem (Pos);
                  Pos := Pos + 1;
               when Iir_Kind_Choice_By_Others =>
                  for I in Rec'Range loop
                     if Rec (I) = No_Valtyp then
                        Set_Elem (Rec'Last - I);
                     end if;
                  end loop;
               when Iir_Kind_Choice_By_Name =>
                  Pos := Nat32 (Get_Element_Position
                                  (Get_Named_Entity
                                     (Get_Choice_Name (Assoc))));
                  Set_Elem (Pos);
               when others =>
                  Error_Msg_Synth
                    (+Assoc, "unhandled association form");
            end case;
            Assoc := Get_Chain (Assoc);
            exit when Is_Null (Assoc);
            exit when not Get_Same_Alternative_Flag (Assoc);
         end loop;
      end loop;
   end Fill_Record_Aggregate;

   function Valtyp_Array_To_Net (Ctxt : Context_Acc; Tab : Valtyp_Array)
                                return Net
   is
      Res : Net;
      Arr : Net_Array_Acc;
      Idx : Nat32;
   begin
      Arr := new Net_Array (1 .. Tab'Length);
      Idx := 0;
      for I in Arr'Range loop
         if Tab (I).Val /= null then
            Idx := Idx + 1;
            Arr (Idx) := Get_Net (Ctxt, Tab (I));
         end if;
      end loop;
      Concat_Array (Ctxt, Arr (1 .. Idx), Res);
      Free_Net_Array (Arr);
      return Res;
   end Valtyp_Array_To_Net;

   function Synth_Aggregate_Array (Syn_Inst : Synth_Instance_Acc;
                                   Aggr : Node;
                                   Aggr_Type : Type_Acc) return Valtyp
   is
      Ctxt : constant Context_Acc := Get_Build (Syn_Inst);
      Strides : constant Stride_Array := Fill_Stride (Aggr_Type);
      Flen : constant Iir_Index32 := Get_Array_Flat_Length (Aggr_Type);
      Tab_Res : Valtyp_Array_Acc;
      Const_P : Boolean;
      Err_P : Boolean;
      Res : Valtyp;
   begin
      Tab_Res := new Valtyp_Array'(1 .. Nat32 (Flen) => No_Valtyp);

      Fill_Array_Aggregate (Syn_Inst, Aggr, Tab_Res,
                            Aggr_Type, 1, Strides, 1, Const_P, Err_P);
      if Err_P then
         return No_Valtyp;
      end if;

      --  TODO: check all element types have the same bounds ?

      if Const_P then
         declare
            Off : Size_Type;
         begin
            Res := Create_Value_Memory (Aggr_Type);
            Off := 0;
            for I in Tab_Res'Range loop
               if Tab_Res (I).Val /= null then
                  --  There can be holes due to sub-arrays.
                  Write_Value (Res.Val.Mem + Off, Tab_Res (I));
                  Off := Off + Tab_Res (I).Typ.Sz;
               end if;
            end loop;
            pragma Assert (Off = Aggr_Type.Sz);
         end;
      else
         Res := Create_Value_Net
           (Valtyp_Array_To_Net (Ctxt, Tab_Res.all), Aggr_Type);
      end if;

      Free_Valtyp_Array (Tab_Res);

      return Res;
   end Synth_Aggregate_Array;

   function Synth_Aggregate_Record (Syn_Inst : Synth_Instance_Acc;
                                    Aggr : Node;
                                    Aggr_Type : Type_Acc) return Valtyp
   is
      Ctxt : constant Context_Acc := Get_Build (Syn_Inst);
      Tab_Res : Valtyp_Array_Acc;
      Res_Typ : Type_Acc;
      Res : Valtyp;
      Err_P : Boolean;
      Const_P : Boolean;
   begin
      --  Allocate the result.
      Tab_Res :=
        new Valtyp_Array'(1 .. Nat32 (Aggr_Type.Rec.Len) => No_Valtyp);

      Fill_Record_Aggregate
        (Syn_Inst, Aggr, Aggr_Type, Tab_Res, Err_P, Const_P);

      if Err_P then
         Res := No_Valtyp;
      else
         case Type_Records (Aggr_Type.Kind) is
            when Type_Unbounded_Record =>
               declare
                  Els_Typ : Rec_El_Array_Acc;
               begin
                  Els_Typ := Create_Rec_El_Array (Aggr_Type.Rec.Len);
                  for I in Els_Typ.E'Range loop
                     Els_Typ.E (I).Typ := Tab_Res (Nat32 (I)).Typ;
                  end loop;
                  Res_Typ := Create_Record_Type (Els_Typ);
               end;
            when Type_Record =>
               Res_Typ := Aggr_Type;
         end case;

         if Const_P then
            Res := Create_Value_Memory (Res_Typ);
            for I in Aggr_Type.Rec.E'Range loop
               Write_Value (Res.Val.Mem + Res_Typ.Rec.E (I).Moff,
                            Tab_Res (Tab_Res'Last - Nat32 (I) + 1));
            end loop;
         else
            Res := Create_Value_Net
              (Valtyp_Array_To_Net (Ctxt, Tab_Res.all), Res_Typ);
         end if;
      end if;

      Free_Valtyp_Array (Tab_Res);

      return Res;
   end Synth_Aggregate_Record;

   --  Aggr_Type is the type from the context.
   function Synth_Aggregate (Syn_Inst : Synth_Instance_Acc;
                             Aggr : Node;
                             Aggr_Type : Type_Acc) return Valtyp is
   begin
      case Aggr_Type.Kind is
         when Type_Unbounded_Array | Type_Unbounded_Vector =>
            declare
               Res_Type : Type_Acc;
            begin
               Res_Type := Decls.Synth_Array_Subtype_Indication
                 (Syn_Inst, Get_Type (Aggr));
               return Synth_Aggregate_Array (Syn_Inst, Aggr, Res_Type);
            end;
         when Type_Vector
           | Type_Array =>
            return Synth_Aggregate_Array (Syn_Inst, Aggr, Aggr_Type);
         when Type_Record
           |  Type_Unbounded_Record =>
            return Synth_Aggregate_Record (Syn_Inst, Aggr, Aggr_Type);
         when others =>
            raise Internal_Error;
      end case;
   end Synth_Aggregate;

end Synth.Aggr;