From 33b307ba8d64ae952334a7f79249178141adee2c Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Fri, 16 Apr 2021 06:44:05 +0200 Subject: synth: refactoring (synth.aggr -> synth.vhdl_aggr) --- src/synth/synth-aggr.adb | 537 ------------------------------------------ src/synth/synth-aggr.ads | 30 --- src/synth/synth-expr.adb | 4 +- src/synth/synth-vhdl_aggr.adb | 537 ++++++++++++++++++++++++++++++++++++++++++ src/synth/synth-vhdl_aggr.ads | 30 +++ 5 files changed, 569 insertions(+), 569 deletions(-) delete mode 100644 src/synth/synth-aggr.adb delete mode 100644 src/synth/synth-aggr.ads create mode 100644 src/synth/synth-vhdl_aggr.adb create mode 100644 src/synth/synth-vhdl_aggr.ads diff --git a/src/synth/synth-aggr.adb b/src/synth/synth-aggr.adb deleted file mode 100644 index 0df9ae9c6..000000000 --- a/src/synth/synth-aggr.adb +++ /dev/null @@ -1,537 +0,0 @@ --- 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, see . - -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; diff --git a/src/synth/synth-aggr.ads b/src/synth/synth-aggr.ads deleted file mode 100644 index d37cd8afe..000000000 --- a/src/synth/synth-aggr.ads +++ /dev/null @@ -1,30 +0,0 @@ --- 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, see . - -with Vhdl.Nodes; use Vhdl.Nodes; - -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; - -package Synth.Aggr is - -- Aggr_Type is the type from the context. - function Synth_Aggregate (Syn_Inst : Synth_Instance_Acc; - Aggr : Node; - Aggr_Type : Type_Acc) return Valtyp; -end Synth.Aggr; diff --git a/src/synth/synth-expr.adb b/src/synth/synth-expr.adb index 15b9914f0..437318257 100644 --- a/src/synth/synth-expr.adb +++ b/src/synth/synth-expr.adb @@ -46,7 +46,7 @@ with Synth.Stmts; use Synth.Stmts; with Synth.Oper; use Synth.Oper; with Synth.Heap; use Synth.Heap; with Synth.Debugger; -with Synth.Aggr; +with Synth.Vhdl_Aggr; with Grt.Types; with Grt.To_Strings; @@ -2395,7 +2395,7 @@ package body Synth.Expr is end case; end; when Iir_Kind_Aggregate => - return Synth.Aggr.Synth_Aggregate (Syn_Inst, Expr, Expr_Type); + return Synth.Vhdl_Aggr.Synth_Aggregate (Syn_Inst, Expr, Expr_Type); when Iir_Kind_Simple_Aggregate => return Synth_Simple_Aggregate (Syn_Inst, Expr); when Iir_Kind_Parenthesis_Expression => diff --git a/src/synth/synth-vhdl_aggr.adb b/src/synth/synth-vhdl_aggr.adb new file mode 100644 index 000000000..6863924f0 --- /dev/null +++ b/src/synth/synth-vhdl_aggr.adb @@ -0,0 +1,537 @@ +-- 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, see . + +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.Vhdl_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 := 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.Vhdl_Aggr; diff --git a/src/synth/synth-vhdl_aggr.ads b/src/synth/synth-vhdl_aggr.ads new file mode 100644 index 000000000..822c0705d --- /dev/null +++ b/src/synth/synth-vhdl_aggr.ads @@ -0,0 +1,30 @@ +-- 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, see . + +with Vhdl.Nodes; use Vhdl.Nodes; + +with Synth.Objtypes; use Synth.Objtypes; +with Synth.Values; use Synth.Values; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; + +package Synth.Vhdl_Aggr is + -- Aggr_Type is the type from the context. + function Synth_Aggregate (Syn_Inst : Synth_Instance_Acc; + Aggr : Node; + Aggr_Type : Type_Acc) return Valtyp; +end Synth.Vhdl_Aggr; -- cgit v1.2.3