-- Expressions synthesis. -- 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 . with Types; use Types; with Name_Table; with Str_Table; with Netlists; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Scanner; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Evaluation; use Vhdl.Evaluation; with Elab.Memtype; use Elab.Memtype; with Elab.Vhdl_Heap; use Elab.Vhdl_Heap; with Elab.Vhdl_Types; use Elab.Vhdl_Types; with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Vhdl_Eval; use Synth.Vhdl_Eval; with Synth.Errors; use Synth.Errors; with Grt.Types; with Grt.Vhdl_Types; with Grt.Strings; with Grt.To_Strings; with Grt.Vstrings; package body Elab.Vhdl_Expr is function Synth_Bounds_From_Length (Atype : Node; Len : Int32) return Bound_Type is Rng : constant Node := Get_Range_Constraint (Atype); Limit : Int32; begin Limit := Int32 (Eval_Pos (Get_Left_Limit (Rng))); case Get_Direction (Rng) is when Dir_To => return (Dir => Dir_To, Left => Limit, Right => Limit + Len - 1, Len => Uns32 (Len)); when Dir_Downto => return (Dir => Dir_Downto, Left => Limit, Right => Limit - Len + 1, Len => Uns32 (Len)); end case; end Synth_Bounds_From_Length; function Exec_Simple_Aggregate (Syn_Inst : Synth_Instance_Acc; Aggr : Node) return Valtyp is Els : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); Last : constant Natural := Flist_Last (Els); Aggr_Type : constant Node := Get_Type (Aggr); Res_Typ : Type_Acc; Val : Valtyp; Res : Valtyp; begin -- Allocate the result. Res_Typ := Synth_Subtype_Indication (Syn_Inst, Aggr_Type); pragma Assert (Get_Nbr_Dimensions (Aggr_Type) = 1); pragma Assert (Res_Typ.Abound.Len = Uns32 (Last + 1)); Res := Create_Value_Memory (Res_Typ, Current_Pool); for I in Flist_First .. Last loop -- Elements are supposed to be static, so no need for enable. Val := Synth_Expression_With_Type (Syn_Inst, Get_Nth_Element (Els, I), Res_Typ.Arr_El); pragma Assert (Is_Static (Val.Val)); Write_Value (Res.Val.Mem + Size_Type (I) * Res_Typ.Arr_El.Sz, Val); end loop; return Res; end Exec_Simple_Aggregate; function Exec_Subtype_Conversion (Vt : Valtyp; Dtype : Type_Acc; Bounds : Boolean; Loc : Node) return Valtyp is begin return Synth_Subtype_Conversion (null, Vt, Dtype, Bounds, Loc); end Exec_Subtype_Conversion; -- Return True iff ID = S, case insensitive. function Match_Id (Id : Name_Id; M : Memory_Ptr; Len : Natural) return Boolean is begin if Name_Table.Get_Name_Length (Id) /= Len then return False; end if; declare Img : constant String (1 .. Len) := Name_Table.Image (Id); C : Character; begin for I in Img'Range loop C := Read_Char (M + Size_Type (I - 1)); C := Grt.Strings.To_Lower (C); if C /= Img (I) then return False; end if; end loop; return True; end; end Match_Id; -- V is the string whose value should be extracted from. ETYPE and DTYPE -- are the type of the value. function Value_Attribute (V : Valtyp; Etype : Node; Dtype : Type_Acc) return Valtyp is Btype : constant Node := Get_Base_Type (Etype); M : constant Memory_Ptr := V.Val.Mem; L : constant Uns32 := V.Typ.Abound.Len; Len : Uns32; First, Last : Size_Type; Val : Int64; begin -- LRM93 14.1 Predefined attributes. -- Leading and trailing whitespace are ignored. First := 0; Last := Size_Type (L - 1); while First <= Last loop exit when not Vhdl.Scanner.Is_Whitespace (Read_Char (M + First)); First := First + 1; end loop; while Last >= First loop exit when not Vhdl.Scanner.Is_Whitespace (Read_Char (M + Last)); Last := Last - 1; end loop; Len := Uns32 (Last - First + 1); case Get_Kind (Btype) is when Iir_Kind_Enumeration_Type_Definition => declare Id : Name_Id; En : Node; begin if Len = 3 and then Read_Char (M + First) = ''' and then Read_Char (M + First + 2) = ''' then Id := Name_Table.Get_Identifier (Read_Char (M + First + 1)); else declare S : String (1 .. Natural (Len)); C : Character; begin for I in S'Range loop C := Read_Char (M + First + Size_Type (I - 1)); C := Grt.Strings.To_Lower (C); S (I) := C; end loop; Id := Name_Table.Get_Identifier_No_Create (S); end; end if; En := Find_Name_In_Flist (Get_Enumeration_Literal_List (Btype), Id); if En = Null_Node then return No_Valtyp; end if; Val := Int64 (Get_Enum_Pos (En)); end; when Iir_Kind_Integer_Type_Definition => declare use Grt.To_Strings; use Grt.Types; use Grt.Vhdl_Types; Res : Value_I64_Result; begin Res := Value_I64 (To_Std_String_Basep (To_Address (M + First)), Ghdl_Index_Type (Len), 0); if Res.Status /= Value_Ok then return No_Valtyp; end if; Val := Int64 (Res.Val); end; when Iir_Kind_Floating_Type_Definition => declare use Grt.To_Strings; use Grt.Types; use Grt.Vhdl_Types; Res : Value_F64_Result; begin Res := Value_F64 (To_Std_String_Basep (To_Address (M + First)), Ghdl_Index_Type (Len), 0); if Res.Status /= Value_Ok then return No_Valtyp; end if; return Create_Value_Float (Fp64 (Res.Val), Dtype); end; when Iir_Kind_Physical_Type_Definition => declare use Grt.Types; use Grt.Vhdl_Types; use Grt.To_Strings; Is_Real : Boolean; Lit_Pos : Ghdl_Index_Type; Lit_End : Ghdl_Index_Type; Unit_Pos : Ghdl_Index_Type; Unit_F : Size_Type; Unit_Len : Natural; Mult : Int64; Unit : Iir; Unit_Id : Name_Id; Val_F : Grt.To_Strings.Value_F64_Result; Val_I : Grt.To_Strings.Value_I64_Result; begin Grt.To_Strings.Ghdl_Value_Physical_Split (To_Std_String_Basep (To_Address (M)), Ghdl_Index_Type (L), Is_Real, Lit_Pos, Lit_End, Unit_Pos); Unit_F := Size_Type (Unit_Pos); -- Find unit. Unit_Len := 0; for I in Unit_F .. Last loop exit when Grt.Strings.Is_Whitespace (Read_Char (M + I)); Unit_Len := Unit_Len + 1; end loop; Unit := Get_Primary_Unit (Btype); while Unit /= Null_Iir loop Unit_Id := Get_Identifier (Unit); exit when Match_Id (Unit_Id, M + Unit_F, Unit_Len); Unit := Get_Chain (Unit); end loop; if Unit = Null_Iir then return No_Valtyp; end if; Mult := Get_Value (Get_Physical_Literal (Unit)); if Is_Real then Val_F := Value_F64 (To_Std_String_Basep (To_Address (M)), Lit_End, Ghdl_Index_Type (First)); if Val_F.Status /= Value_Ok then return No_Valtyp; end if; Val := Int64 (Val_F.Val * Ghdl_F64 (Mult)); else Val_I := Value_I64 (To_Std_String_Basep (To_Address (M)), Lit_End, Ghdl_Index_Type (First)); if Val_I.Status /= Value_Ok then return No_Valtyp; end if; Val := Int64 (Val_I.Val) * Mult; end if; end; when others => raise Internal_Error; end case; return Create_Value_Discrete (Val, Dtype); end Value_Attribute; function Exec_Value_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) return Valtyp is Param : constant Node := Get_Parameter (Attr); Etype : constant Node := Get_Type (Attr); V : Valtyp; Dtype : Type_Acc; Res : Valtyp; begin -- The value is supposed to be static. V := Synth_Expression (Syn_Inst, Param); if V = No_Valtyp then return No_Valtyp; end if; Dtype := Get_Subtype_Object (Syn_Inst, Etype); if not Is_Static (V.Val) then Error_Msg_Elab (+Attr, "parameter of 'value must be static"); return No_Valtyp; end if; Res := Value_Attribute (V, Etype, Dtype); if Res = No_Valtyp then Error_Msg_Synth (Syn_Inst, Attr, "incorrect 'value string"); end if; return Res; end Exec_Value_Attribute; function Synth_Image_Attribute_Str (Val : Valtyp; Expr_Type : Iir) return String is use Grt.Types; begin case Get_Kind (Expr_Type) is when Iir_Kind_Floating_Type_Definition | Iir_Kind_Floating_Subtype_Definition => declare Str : String (1 .. 24); Last : Natural; begin Grt.To_Strings.To_String (Str, Last, Ghdl_F64 (Read_Fp64 (Val))); return Str (Str'First .. Last); end; when Iir_Kind_Integer_Type_Definition | Iir_Kind_Integer_Subtype_Definition => declare Str : String (1 .. 21); First : Natural; begin Grt.To_Strings.To_String (Str, First, Ghdl_I64 (Read_Discrete (Val))); return Str (First .. Str'Last); end; when Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Enumeration_Subtype_Definition => declare Lits : constant Iir_Flist := Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); begin return Name_Table.Image (Get_Identifier (Get_Nth_Element (Lits, Natural (Read_Discrete (Val))))); end; when Iir_Kind_Physical_Type_Definition | Iir_Kind_Physical_Subtype_Definition => declare Str : String (1 .. 21); First : Natural; Id : constant Name_Id := Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); begin Grt.To_Strings.To_String (Str, First, Ghdl_I64 (Read_Discrete (Val))); return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); end; when others => Error_Kind ("synth_image_attribute_str", Expr_Type); end case; end Synth_Image_Attribute_Str; function Exec_Image_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) return Valtyp is Param : constant Node := Get_Parameter (Attr); Etype : constant Node := Get_Type (Attr); V : Valtyp; Dtype : Type_Acc; Res : Memtyp; begin -- The parameter is expected to be static. V := Synth_Expression (Syn_Inst, Param); if V = No_Valtyp then return No_Valtyp; end if; Dtype := Get_Subtype_Object (Syn_Inst, Etype); if not Is_Static (V.Val) then Error_Msg_Elab (+Attr, "parameter of 'image must be static"); return No_Valtyp; end if; Strip_Const (V); Res := String_To_Memtyp (Synth_Image_Attribute_Str (V, Get_Type (Param)), Dtype); return Create_Value_Memtyp (Res); end Exec_Image_Attribute; function Exec_Instance_Name_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) return Valtyp is Atype : constant Node := Get_Type (Attr); Atyp : constant Type_Acc := Get_Subtype_Object (Syn_Inst, Atype); Name : constant Path_Instance_Name_Type := Get_Path_Instance_Name_Suffix (Attr); Res : Memtyp; begin -- Return a truncated name, as the prefix is not completly known. Res := String_To_Memtyp (Name.Suffix, Atyp); return Create_Value_Memtyp (Res); end Exec_Instance_Name_Attribute; procedure Check_Matching_Bounds (L, R : Type_Acc; Loc : Node) is begin if not Are_Types_Equal (L, R) then Error_Msg_Elab (+Loc, "non matching bounds"); end if; end Check_Matching_Bounds; -- Return the bounds of a one dimensional array/vector type and the -- width of the element. procedure Get_Onedimensional_Array_Bounds (Typ : Type_Acc; Bnd : out Bound_Type; El_Typ : out Type_Acc) is begin case Typ.Kind is when Type_Array | Type_Vector => pragma Assert (Typ.Alast); El_Typ := Typ.Arr_El; Bnd := Typ.Abound; when others => raise Internal_Error; end case; end Get_Onedimensional_Array_Bounds; function Create_Onedimensional_Array_Subtype (Btyp : Type_Acc; Bnd : Bound_Type; El_Typ : Type_Acc) return Type_Acc is Res : Type_Acc; begin case Btyp.Kind is when Type_Vector => pragma Assert (El_Typ.Kind in Type_Nets); Res := Create_Vector_Type (Bnd, Btyp.Arr_El); when Type_Unbounded_Vector => pragma Assert (El_Typ.Kind in Type_Nets); Res := Create_Vector_Type (Bnd, Btyp.Uarr_El); when Type_Array => pragma Assert (Btyp.Alast); pragma Assert (Is_Bounded_Type (Btyp.Arr_El)); Res := Create_Array_Type (Bnd, True, Btyp.Arr_El); when Type_Unbounded_Array => pragma Assert (Btyp.Ulast); pragma Assert (Is_Bounded_Type (El_Typ)); Res := Create_Array_Type (Bnd, True, El_Typ); when others => raise Internal_Error; end case; return Res; end Create_Onedimensional_Array_Subtype; function Exec_Name_Subtype (Syn_Inst : Synth_Instance_Acc; Name : Node) return Type_Acc is begin case Get_Kind (Name) is when Iir_Kind_Simple_Name | Iir_Kind_Selected_Name => return Exec_Name_Subtype (Syn_Inst, Get_Named_Entity (Name)); when Iir_Kind_Parenthesis_Expression => return Exec_Name_Subtype (Syn_Inst, Get_Expression (Name)); when Iir_Kinds_Object_Declaration => return Get_Value (Syn_Inst, Name).Typ; when Iir_Kind_Selected_Element => declare Idx : constant Iir_Index32 := Get_Element_Position (Get_Named_Entity (Name)); Pfx : constant Node := Get_Prefix (Name); Res : Type_Acc; begin Res := Exec_Name_Subtype (Syn_Inst, Pfx); Res := Res.Rec.E (Idx + 1).Typ; return Res; end; when Iir_Kind_Indexed_Name => declare Pfx : constant Node := Get_Prefix (Name); Res : Type_Acc; begin Res := Exec_Name_Subtype (Syn_Inst, Pfx); return Res.Arr_El; end; when Iir_Kind_Slice_Name => declare use Netlists; Pfx_Typ : Type_Acc; Pfx_Bnd : Bound_Type; El_Typ : Type_Acc; Res_Bnd : Bound_Type; Sl_Off : Value_Offsets; Inp : Net; Err : Boolean; begin Pfx_Typ := Exec_Name_Subtype (Syn_Inst, Get_Prefix (Name)); Get_Onedimensional_Array_Bounds (Pfx_Typ, Pfx_Bnd, El_Typ); Synth_Slice_Suffix (Syn_Inst, Name, Pfx_Bnd, Pfx_Typ.Wkind, El_Typ, Res_Bnd, Inp, Sl_Off, Err); if Err then return null; end if; pragma Assert (Inp = No_Net); return Create_Onedimensional_Array_Subtype (Pfx_Typ, Res_Bnd, El_Typ); end; when Iir_Kind_Implicit_Dereference | Iir_Kind_Dereference => declare Val : Valtyp; Obj : Memtyp; begin -- Maybe do not dereference it if its type is known ? Val := Synth_Expression (Syn_Inst, Get_Prefix (Name)); Obj := Elab.Vhdl_Heap.Synth_Dereference (Read_Access (Val)); return Obj.Typ; end; when Iir_Kind_Function_Call => declare Ret_Typ : Type_Acc; Val : Valtyp; begin Ret_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Name)); if Is_Bounded_Type (Ret_Typ) then return Ret_Typ; end if; -- Humm, is it an error ? Val := Synth.Vhdl_Expr.Synth_Expression (Syn_Inst, Name); return Val.Typ; end; when Iir_Kind_Enumeration_Literal | Iir_Kind_Unit_Declaration => return Get_Subtype_Object (Syn_Inst, Get_Type (Name)); when Iir_Kind_String_Literal8 | Iir_Kind_Aggregate => -- TODO: the value should be computed (once) and its type -- returned. return Synth_Subtype_Indication (Syn_Inst, Get_Type (Name)); when Iir_Kind_Image_Attribute => declare Val : Valtyp; begin Val := Synth.Vhdl_Expr.Synth_Expression (Syn_Inst, Name); return Val.Typ; end; when Iir_Kind_Element_Attribute => declare Pfx : Type_Acc; begin Pfx := Exec_Name_Subtype (Syn_Inst, Get_Prefix (Name)); return Pfx.Arr_El; end; when others => Error_Kind ("exec_name_subtype", Name); end case; end Exec_Name_Subtype; function Exec_String_Literal (Syn_Inst : Synth_Instance_Acc; Str : Node; Str_Typ : Type_Acc) return Valtyp is pragma Assert (Get_Kind (Str) = Iir_Kind_String_Literal8); Id : constant String8_Id := Get_String8_Id (Str); Len : constant Int32 := Get_String_Length (Str); Str_Type : constant Node := Get_Type (Str); El_Type : Type_Acc; Bounds : Bound_Type; Res_Type : Type_Acc; Res : Valtyp; Pos : Nat8; begin case Str_Typ.Kind is when Type_Vector | Type_Array => Bounds := Str_Typ.Abound; if Bounds.Len /= Uns32 (Len) then Error_Msg_Synth (Syn_Inst, Str, "string length doesn't match constraints"); return No_Valtyp; end if; when Type_Unbounded_Vector | Type_Unbounded_Array => Bounds := Synth_Bounds_From_Length (Get_Index_Type (Str_Type, 0), Len); when others => raise Internal_Error; end case; El_Type := Get_Array_Element (Str_Typ); if El_Type.Kind in Type_Nets then Res_Type := Create_Vector_Type (Bounds, El_Type); else Res_Type := Create_Array_Type (Bounds, True, El_Type); end if; Res := Create_Value_Memory (Res_Type, Current_Pool); -- Only U8 are handled. pragma Assert (El_Type.Sz = 1); -- From left to right. for I in 1 .. Bounds.Len loop -- FIXME: use literal from type ?? Pos := Str_Table.Element_String8 (Id, Pos32 (I)); Write_U8 (Res.Val.Mem + Size_Type (I - 1), Nat8'Pos (Pos)); end loop; return Res; end Exec_String_Literal; function Exec_Path_Instance_Name_Attribute (Inst : Synth_Instance_Acc; Attr : Iir) return Memtyp is use Grt.Vstrings; use Name_Table; Is_Instance : constant Boolean := Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; Atype : constant Node := Get_Type (Attr); Str_Typ : constant Type_Acc := Get_Subtype_Object (Inst, Atype); Name : constant Path_Instance_Name_Type := Get_Path_Instance_Name_Suffix (Attr); Instance, Parent : Synth_Instance_Acc; Rstr : Rstring; Label, Stmt : Node; begin if Name.Path_Instance = Null_Iir then return String_To_Memtyp (Name.Suffix, Str_Typ); end if; Instance := Get_Instance_By_Scope (Inst, Get_Info_Scope (Name.Path_Instance)); loop Parent := Get_Instance_Parent (Instance); if Parent = Root_Instance then Parent := null; end if; Label := Get_Source_Scope (Instance); Stmt := Get_Statement_Scope (Instance); case Get_Kind (Label) is when Iir_Kind_Entity_Declaration => if Parent = null then Prepend (Rstr, Image (Get_Identifier (Label))); exit; end if; when Iir_Kind_Architecture_Body => if Is_Instance then Prepend (Rstr, ')'); Prepend (Rstr, Image (Get_Identifier (Label))); Prepend (Rstr, '('); end if; if Is_Instance or else Parent = null then Prepend (Rstr, Image (Get_Identifier (Get_Entity (Label)))); end if; if Parent = null then Prepend (Rstr, ':'); exit; end if; when Iir_Kind_Block_Statement => Prepend (Rstr, Image (Get_Label (Label))); Prepend (Rstr, ':'); when Iir_Kind_Generate_Statement_Body => declare Gen : constant Node := Get_Parent (Label); begin case Iir_Kinds_Generate_Statement (Get_Kind (Gen)) is when Iir_Kind_For_Generate_Statement => declare It : constant Node := Get_Parameter_Specification (Gen); Val : Valtyp; begin Val := Get_Value (Instance, It); Prepend (Rstr, ')'); Prepend (Rstr, Synth_Image_Attribute_Str (Val, Get_Type (It))); Prepend (Rstr, '('); end; -- Skip the for generate instance. Parent := Get_Instance_Parent (Parent); when Iir_Kind_If_Generate_Statement | Iir_Kind_Case_Generate_Statement => null; end case; Prepend (Rstr, Image (Get_Label (Gen))); Prepend (Rstr, ':'); end; when Iir_Kind_Component_Declaration => if Is_Instance then Prepend (Rstr, '@'); end if; Prepend (Rstr, Image (Get_Label (Stmt))); Prepend (Rstr, ':'); when others => Error_Kind ("Exec_Path_Instance_Name_Attribute", Label); end case; Instance := Parent; end loop; declare Str1 : String (1 .. Length (Rstr)); Len1 : Natural; begin Copy (Rstr, Str1, Len1); Free (Rstr); return String_To_Memtyp (Str1 & ':' & Name.Suffix, Str_Typ); end; end Exec_Path_Instance_Name_Attribute; end Elab.Vhdl_Expr;