From 86fd1ab3079b50c5b7234db2cedf3d1e8c0f081b Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Mon, 1 Nov 2021 19:50:19 +0100 Subject: synth: do full elaboration before synthesis --- src/synth/elab-debugger.adb | 41 + src/synth/elab-debugger.ads | 37 + src/synth/elab-debugger__on.adb | 1296 ++++++++++++++++++++++++++++ src/synth/elab-memtype.adb | 117 +++ src/synth/elab-memtype.ads | 58 ++ src/synth/elab-vhdl_context-debug.adb | 73 ++ src/synth/elab-vhdl_context-debug.ads | 22 + src/synth/elab-vhdl_context.adb | 514 +++++++++++ src/synth/elab-vhdl_context.ads | 222 +++++ src/synth/elab-vhdl_decls.adb | 361 ++++++++ src/synth/elab-vhdl_decls.ads | 40 + src/synth/elab-vhdl_errors.adb | 58 ++ src/synth/elab-vhdl_errors.ads | 38 + src/synth/elab-vhdl_expr.adb | 1402 +++++++++++++++++++++++++++++++ src/synth/elab-vhdl_expr.ads | 80 ++ src/synth/elab-vhdl_files.adb | 418 +++++++++ src/synth/elab-vhdl_files.ads | 47 ++ src/synth/elab-vhdl_heap.adb | 93 ++ src/synth/elab-vhdl_heap.ads | 30 + src/synth/elab-vhdl_insts.adb | 673 +++++++++++++++ src/synth/elab-vhdl_insts.ads | 36 + src/synth/elab-vhdl_objtypes.adb | 784 +++++++++++++++++ src/synth/elab-vhdl_objtypes.ads | 297 +++++++ src/synth/elab-vhdl_stmts.adb | 231 +++++ src/synth/elab-vhdl_stmts.ads | 29 + src/synth/elab-vhdl_types.adb | 562 +++++++++++++ src/synth/elab-vhdl_types.ads | 62 ++ src/synth/elab-vhdl_values-debug.adb | 208 +++++ src/synth/elab-vhdl_values-debug.ads | 23 + src/synth/elab-vhdl_values.adb | 500 +++++++++++ src/synth/elab-vhdl_values.ads | 178 ++++ src/synth/elab.ads | 21 + src/synth/synth-debugger.adb | 41 - src/synth/synth-debugger.ads | 37 - src/synth/synth-debugger__on.adb | 1278 ---------------------------- src/synth/synth-disp_vhdl.adb | 4 +- src/synth/synth-disp_vhdl.ads | 2 +- src/synth/synth-ieee-numeric_std.adb | 3 +- src/synth/synth-ieee-numeric_std.ads | 2 +- src/synth/synth-ieee-std_logic_1164.ads | 2 +- src/synth/synth-memtype.adb | 117 --- src/synth/synth-memtype.ads | 58 -- src/synth/synth-objtypes.adb | 776 ----------------- src/synth/synth-objtypes.ads | 296 ------- src/synth/synth-static_oper.adb | 9 +- src/synth/synth-static_oper.ads | 4 +- src/synth/synth-values-debug.adb | 198 ----- src/synth/synth-values-debug.ads | 23 - src/synth/synth-values.adb | 513 ----------- src/synth/synth-values.ads | 176 ---- src/synth/synth-vhdl_aggr.adb | 7 +- src/synth/synth-vhdl_aggr.ads | 6 +- src/synth/synth-vhdl_context.adb | 463 ++++------ src/synth/synth-vhdl_context.ads | 147 +--- src/synth/synth-vhdl_decls.adb | 769 ++++------------- src/synth/synth-vhdl_decls.ads | 39 +- src/synth/synth-vhdl_environment.ads | 6 +- src/synth/synth-vhdl_expr.adb | 284 ++----- src/synth/synth-vhdl_expr.ads | 34 +- src/synth/synth-vhdl_files.adb | 416 --------- src/synth/synth-vhdl_files.ads | 48 -- src/synth/synth-vhdl_heap.adb | 94 --- src/synth/synth-vhdl_heap.ads | 30 - src/synth/synth-vhdl_insts.adb | 410 ++------- src/synth/synth-vhdl_insts.ads | 10 +- src/synth/synth-vhdl_oper.adb | 5 +- src/synth/synth-vhdl_oper.ads | 6 +- src/synth/synth-vhdl_static_proc.adb | 9 +- src/synth/synth-vhdl_static_proc.ads | 3 +- src/synth/synth-vhdl_stmts.adb | 231 ++--- src/synth/synth-vhdl_stmts.ads | 16 +- src/synth/synthesis.adb | 22 +- src/synth/synthesis.ads | 10 +- 73 files changed, 9225 insertions(+), 5930 deletions(-) create mode 100644 src/synth/elab-debugger.adb create mode 100644 src/synth/elab-debugger.ads create mode 100644 src/synth/elab-debugger__on.adb create mode 100644 src/synth/elab-memtype.adb create mode 100644 src/synth/elab-memtype.ads create mode 100644 src/synth/elab-vhdl_context-debug.adb create mode 100644 src/synth/elab-vhdl_context-debug.ads create mode 100644 src/synth/elab-vhdl_context.adb create mode 100644 src/synth/elab-vhdl_context.ads create mode 100644 src/synth/elab-vhdl_decls.adb create mode 100644 src/synth/elab-vhdl_decls.ads create mode 100644 src/synth/elab-vhdl_errors.adb create mode 100644 src/synth/elab-vhdl_errors.ads create mode 100644 src/synth/elab-vhdl_expr.adb create mode 100644 src/synth/elab-vhdl_expr.ads create mode 100644 src/synth/elab-vhdl_files.adb create mode 100644 src/synth/elab-vhdl_files.ads create mode 100644 src/synth/elab-vhdl_heap.adb create mode 100644 src/synth/elab-vhdl_heap.ads create mode 100644 src/synth/elab-vhdl_insts.adb create mode 100644 src/synth/elab-vhdl_insts.ads create mode 100644 src/synth/elab-vhdl_objtypes.adb create mode 100644 src/synth/elab-vhdl_objtypes.ads create mode 100644 src/synth/elab-vhdl_stmts.adb create mode 100644 src/synth/elab-vhdl_stmts.ads create mode 100644 src/synth/elab-vhdl_types.adb create mode 100644 src/synth/elab-vhdl_types.ads create mode 100644 src/synth/elab-vhdl_values-debug.adb create mode 100644 src/synth/elab-vhdl_values-debug.ads create mode 100644 src/synth/elab-vhdl_values.adb create mode 100644 src/synth/elab-vhdl_values.ads create mode 100644 src/synth/elab.ads delete mode 100644 src/synth/synth-debugger.adb delete mode 100644 src/synth/synth-debugger.ads delete mode 100644 src/synth/synth-debugger__on.adb delete mode 100644 src/synth/synth-memtype.adb delete mode 100644 src/synth/synth-memtype.ads delete mode 100644 src/synth/synth-objtypes.adb delete mode 100644 src/synth/synth-objtypes.ads delete mode 100644 src/synth/synth-values-debug.adb delete mode 100644 src/synth/synth-values-debug.ads delete mode 100644 src/synth/synth-values.adb delete mode 100644 src/synth/synth-values.ads delete mode 100644 src/synth/synth-vhdl_files.adb delete mode 100644 src/synth/synth-vhdl_files.ads delete mode 100644 src/synth/synth-vhdl_heap.adb delete mode 100644 src/synth/synth-vhdl_heap.ads (limited to 'src/synth') diff --git a/src/synth/elab-debugger.adb b/src/synth/elab-debugger.adb new file mode 100644 index 000000000..9121cc3a9 --- /dev/null +++ b/src/synth/elab-debugger.adb @@ -0,0 +1,41 @@ +-- Debugging during synthesis (not enabled). +-- Copyright (C) 2019 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; + +package body Elab.Debugger is + procedure Debug_Init (Top : Node) is + begin + null; + end Debug_Init; + + procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is + begin + raise Internal_Error; + end Debug_Break; + + procedure Debug_Leave (Inst : Synth_Instance_Acc) is + begin + raise Internal_Error; + end Debug_Leave; + + procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is + begin + null; + end Debug_Error; +end Elab.Debugger; diff --git a/src/synth/elab-debugger.ads b/src/synth/elab-debugger.ads new file mode 100644 index 000000000..2b6a79b32 --- /dev/null +++ b/src/synth/elab-debugger.ads @@ -0,0 +1,37 @@ +-- Debugging during synthesis. +-- Copyright (C) 2019 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 Elab.Vhdl_Context; use Elab.Vhdl_Context; + +package Elab.Debugger is + -- If true, debugging is enabled: + -- * call Debug_Break() before executing the next sequential statement + -- * call Debug_Leave when a frame is destroyed. + Flag_Need_Debug : Boolean := False; + + procedure Debug_Init (Top : Node); + procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node); + + procedure Debug_Leave (Inst : Synth_Instance_Acc); + + -- To be called in case of execution error, like: + -- * index out of bounds. + procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node); +end Elab.Debugger; diff --git a/src/synth/elab-debugger__on.adb b/src/synth/elab-debugger__on.adb new file mode 100644 index 000000000..608edbb07 --- /dev/null +++ b/src/synth/elab-debugger__on.adb @@ -0,0 +1,1296 @@ +-- Debugging during synthesis. +-- Copyright (C) 2019 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 System; + +with Types; use Types; +with Files_Map; +with Tables; +with Simple_IO; use Simple_IO; +with Utils_IO; use Utils_IO; +with Name_Table; +with Str_Table; +with Libraries; + +with Grt.Readline; + +with Vhdl.Errors; +with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk; +with Vhdl.Parse; +with Vhdl.Utils; use Vhdl.Utils; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Context.Debug; use Elab.Vhdl_Context.Debug; + +package body Elab.Debugger is + Flag_Enabled : Boolean := False; + + Current_Instance : Synth_Instance_Acc; + Current_Loc : Node; + + type Debug_Reason is + ( + Reason_Init, + Reason_Break, + Reason_Error + ); + + package Breakpoints is new Tables + (Table_Index_Type => Natural, + Table_Component_Type => Node, + Table_Low_Bound => 1, + Table_Initial => 16); + + function Is_Breakpoint_Hit return Boolean is + begin + for I in Breakpoints.First .. Breakpoints.Last loop + if Breakpoints.Table (I) = Current_Loc then + return True; + end if; + end loop; + return False; + end Is_Breakpoint_Hit; + + -- Current execution state, or reason to stop execution (set by the + -- last debugger command). + type Exec_State_Type is + (-- Execution should continue until a breakpoint is reached or assertion + -- failure. + Exec_Run, + + -- Execution will stop at the next statement. + Exec_Single_Step, + + -- Execution will stop at the next simple statement in the same frame. + Exec_Next, + + -- Execution will stop at the next statement in the same frame. In + -- case of compound statement, stop after the compound statement. + Exec_Next_Stmt); + + Exec_State : Exec_State_Type := Exec_Run; + + -- Current frame for next. + Exec_Instance : Synth_Instance_Acc; + + -- Current statement for next_stmt. + Exec_Statement : Node; + + function Is_Within_Statement (Stmt : Node; Cur : Node) return Boolean + is + Parent : Node; + begin + Parent := Cur; + loop + if Parent = Stmt then + return True; + end if; + case Get_Kind (Parent) is + when Iir_Kinds_Sequential_Statement => + Parent := Get_Parent (Parent); + when others => + return False; + end case; + end loop; + end Is_Within_Statement; + + Prompt_Debug : constant String := "debug> " & ASCII.NUL; + Prompt_Error : constant String := "error> " & ASCII.NUL; + Prompt_Init : constant String := "init> " & ASCII.NUL; + -- Prompt_Elab : constant String := "elab> " & ASCII.NUL; + + procedure Disp_Iir_Location (N : Node) is + begin + if N = Null_Iir then + Put_Err ("??:??:??"); + else + Put_Err (Vhdl.Errors.Disp_Location (N)); + end if; + Put_Err (": "); + end Disp_Iir_Location; + + -- For the list command: current file and current line. + List_Current_File : Source_File_Entry := No_Source_File_Entry; + List_Current_Line : Natural := 0; + List_Current_Line_Pos : Source_Ptr := 0; + + -- Set List_Current_* from a location. To be called after program break + -- to indicate current location. + procedure Set_List_Current (Loc : Location_Type) + is + Offset : Natural; + begin + Files_Map.Location_To_Coord + (Loc, List_Current_File, List_Current_Line_Pos, + List_Current_Line, Offset); + end Set_List_Current; + + procedure Disp_Current_Lines + is + use Files_Map; + -- Number of lines to display before and after the current line. + Radius : constant := 5; + + Buf : File_Buffer_Acc; + + Pos : Source_Ptr; + Line : Natural; + Len : Source_Ptr; + C : Character; + begin + if List_Current_Line > Radius then + Line := List_Current_Line - Radius; + else + Line := 1; + end if; + + Pos := File_Line_To_Position (List_Current_File, Line); + Buf := Get_File_Source (List_Current_File); + + while Line < List_Current_Line + Radius loop + -- Compute line length. + Len := 0; + loop + C := Buf (Pos + Len); + exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; + Len := Len + 1; + end loop; + + -- Disp line number. + declare + Str : constant String := Natural'Image (Line); + begin + if Line = List_Current_Line then + Put ('*'); + else + Put (' '); + end if; + Put ((Str'Length .. 5 => ' ')); + Put (Str (Str'First + 1 .. Str'Last)); + Put (' '); + end; + + -- Disp line. + Put_Line (String (Buf (Pos .. Pos + Len - 1))); + + -- Skip EOL. + exit when C = ASCII.EOT; + Pos := Pos + Len + 1; + if C = ASCII.CR then + if Buf (Pos) = ASCII.LF then + Pos := Pos + 1; + end if; + else + pragma Assert (C = ASCII.LF); + if Buf (Pos) = ASCII.CR then + Pos := Pos + 1; + end if; + end if; + + Line := Line + 1; + end loop; + end Disp_Current_Lines; + + procedure Disp_Source_Line (Loc : Location_Type) + is + use Files_Map; + + File : Source_File_Entry; + Line_Pos : Source_Ptr; + Line : Natural; + Offset : Natural; + Buf : File_Buffer_Acc; + Next_Line_Pos : Source_Ptr; + begin + Location_To_Coord (Loc, File, Line_Pos, Line, Offset); + Buf := Get_File_Source (File); + Next_Line_Pos := File_Line_To_Position (File, Line + 1); + Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); + end Disp_Source_Line; + + -- The status of the debugger. This status can be modified by a command + -- as a side effect to resume or quit the debugger. + type Command_Status_Type is (Status_Default, Status_Quit); + Command_Status : Command_Status_Type; + + -- This exception can be raised by a debugger command to directly return + -- to the prompt. + Command_Error : exception; + + type Menu_Procedure is access procedure (Line : String); + + -- If set (by commands), call this procedure on empty line to repeat + -- last command. + Cmd_Repeat : Menu_Procedure; + + type Menu_Kind is (Menu_Command, Menu_Submenu); + type Menu_Entry (Kind : Menu_Kind); + type Menu_Entry_Acc is access all Menu_Entry; + + type Cst_String_Acc is access constant String; + + type Menu_Entry (Kind : Menu_Kind) is record + Name : Cst_String_Acc; + Next : Menu_Entry_Acc; + + case Kind is + when Menu_Command => + Proc : Menu_Procedure; + when Menu_Submenu => + First, Last : Menu_Entry_Acc := null; + end case; + end record; + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + function Skip_Blanks (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P; + end Skip_Blanks; + + -- Return the position of the last character of the word (the last + -- non-blank character). + function Get_Word (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then not Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P - 1; + end Get_Word; + + procedure Disp_Memtyp (M : Memtyp; Vtype : Node); + + procedure Disp_Discrete_Value (Val : Int64; Btype : Node) is + begin + case Get_Kind (Btype) is + when Iir_Kind_Integer_Type_Definition => + Put_Int64 (Val); + when Iir_Kind_Enumeration_Type_Definition => + declare + Pos : constant Natural := Natural (Val); + Enums : constant Node_Flist := + Get_Enumeration_Literal_List (Btype); + Id : constant Name_Id := + Get_Identifier (Get_Nth_Element (Enums, Pos)); + begin + Put (Name_Table.Image (Id)); + end; + when others => + Vhdl.Errors.Error_Kind ("disp_discrete_value", Btype); + end case; + end Disp_Discrete_Value; + + procedure Disp_Value_Vector (Mem : Memtyp; A_Type: Node; Bound : Bound_Type) + is + El_Type : constant Node := Get_Base_Type (Get_Element_Subtype (A_Type)); + El_Typ : constant Type_Acc := Get_Array_Element (Mem.Typ); + type Last_Enum_Type is (None, Char, Identifier); + Last_Enum : Last_Enum_Type; + Enum_List : Node_Flist; + El_Id : Name_Id; + El_Pos : Natural; + begin + -- Pretty print vectors of enumerated types + if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition then + Last_Enum := None; + Enum_List := Get_Enumeration_Literal_List (El_Type); + for I in 1 .. Bound.Len loop + El_Pos := Natural + (Read_Discrete + (Memtyp'(El_Typ, Mem.Mem + Size_Type (I - 1) * El_Typ.Sz))); + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then + case Last_Enum is + when None => + Put (""""); + when Identifier => + Put (" & """); + when Char => + null; + end case; + Put (Name_Table.Get_Character (El_Id)); + Last_Enum := Char; + else + case Last_Enum is + when None => + null; + when Identifier => + Put (" & "); + when Char => + Put (""" & "); + end case; + Put (Name_Table.Image (El_Id)); + Last_Enum := Identifier; + end if; + end loop; + case Last_Enum is + when None => + Put (""""""); -- Simply "" + when Identifier => + null; + when Char => + Put (""""); + end case; + else + Put ("("); + for I in 1 .. Bound.Len loop + if I /= 1 then + Put (", "); + end if; + Disp_Memtyp ((El_Typ, Mem.Mem + Size_Type (I - 1) * Mem.Typ.Sz), + El_Type); + end loop; + Put (")"); + end if; + end Disp_Value_Vector; + + procedure Disp_Value_Array (Mem : Memtyp; A_Type: Node; Dim: Dim_Type) + is + Stride : Size_Type; + begin + if Dim = Mem.Typ.Abounds.Ndim then + -- Last dimension + Disp_Value_Vector (Mem, A_Type, Mem.Typ.Abounds.D (Dim)); + else + Stride := Mem.Typ.Arr_El.Sz; + for I in Dim + 1 .. Mem.Typ.Abounds.Ndim loop + Stride := Stride * Size_Type (Mem.Typ.Abounds.D (I).Len); + end loop; + + Put ("("); + for I in 1 .. Mem.Typ.Abounds.D (Dim).Len loop + if I /= 1 then + Put (", "); + end if; + Disp_Value_Array ((Mem.Typ, Mem.Mem + Stride), A_Type, Dim + 1); + end loop; + Put (")"); + end if; + end Disp_Value_Array; + + procedure Disp_Memtyp (M : Memtyp; Vtype : Node) is + begin + if M.Mem = null then + Put ("*NULL*"); + return; + end if; + + case M.Typ.Kind is + when Type_Discrete + | Type_Bit + | Type_Logic => + Disp_Discrete_Value (Read_Discrete (M), Get_Base_Type (Vtype)); + when Type_Vector => + Disp_Value_Vector (M, Vtype, M.Typ.Vbound); + when Type_Array => + Disp_Value_Array (M, Vtype, 1); + when Type_Float => + Put ("*float*"); + when Type_Slice => + Put ("*slice*"); + when Type_File => + Put ("*file*"); + when Type_Record => + Put ("*record*"); + when Type_Access => + Put ("*access*"); + when Type_Protected => + Put ("*protected*"); + when Type_Unbounded_Array + | Type_Unbounded_Record + | Type_Unbounded_Vector => + Put ("*unbounded*"); + end case; + end Disp_Memtyp; + + procedure Disp_Value (Vt : Valtyp; Vtype : Node) is + begin + if Vt.Val = null then + Put ("*NULL*"); + return; + end if; + + case Vt.Val.Kind is + when Value_Net => + Put ("net"); + when Value_Wire => + Put ("wire"); + when Value_Signal => + Put ("signal"); + when Value_File => + Put ("file"); + when Value_Const => + Put ("const: "); + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + when Value_Alias => + Put ("alias"); + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + when Value_Memory => + Disp_Memtyp (Get_Memtyp (Vt), Vtype); + end case; + end Disp_Value; + + procedure Disp_Bound_Type (Bound : Bound_Type) is + begin + Put_Int32 (Bound.Left); + Put (' '); + case Bound.Dir is + when Dir_To => + Put ("to"); + when Dir_Downto => + Put ("downto"); + end case; + Put (' '); + Put_Int32 (Bound.Right); + end Disp_Bound_Type; + + procedure Disp_Type (Typ : Type_Acc; Vtype : Node) + is + pragma Unreferenced (Vtype); + begin + case Typ.Kind is + when Type_Bit => + Put ("bit"); + when Type_Logic => + Put ("logic"); + when Type_Discrete => + Put ("discrete"); + when Type_Float => + Put ("float"); + when Type_Vector => + Put ("vector ("); + Disp_Bound_Type (Typ.Vbound); + Put (')'); + when Type_Unbounded_Vector => + Put ("unbounded_vector"); + when Type_Array => + Put ("array"); + when Type_Unbounded_Array => + Put ("unbounded_array"); + when Type_Unbounded_Record => + Put ("unbounded_record"); + when Type_Record => + Put ("record"); + when Type_Slice => + Put ("slice"); + when Type_Access => + Put ("access"); + when Type_File => + Put ("file"); + when Type_Protected => + Put ("protected"); + end case; + end Disp_Type; + + procedure Disp_Declaration_Object + (Instance : Synth_Instance_Acc; Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration => + declare + Val : constant Valtyp := Get_Value (Instance, Decl); + Dtype : constant Node := Get_Type (Decl); + begin + Put (Vhdl.Errors.Disp_Node (Decl)); + Put (": "); + Disp_Type (Val.Typ, Dtype); + Put (" = "); + Disp_Value (Val, Dtype); + New_Line; + end; + when Iir_Kinds_Signal_Attribute => + -- FIXME: todo ? + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when Iir_Kind_Function_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Procedure_Body => + null; + when others => + Vhdl.Errors.Error_Kind ("disp_declaration_object", Decl); + end case; + end Disp_Declaration_Object; + + procedure Disp_Declaration_Objects + (Instance : Synth_Instance_Acc; Decl_Chain : Iir) + is + El : Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + Disp_Declaration_Object (Instance, El); + El := Get_Chain (El); + end loop; + end Disp_Declaration_Objects; + + procedure Info_Params_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Params : Iir; + begin + Decl := Get_Source_Scope (Current_Instance); + loop + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + Decl := Get_Subprogram_Specification (Decl); + exit; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Put_Line ("processes have no parameters"); + return; + when Iir_Kind_While_Loop_Statement + | Iir_Kind_If_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Case_Statement => + Decl := Get_Parent (Decl); + when others => + Vhdl.Errors.Error_Kind ("info_params_proc", Decl); + end case; + end loop; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Current_Instance, Params); + end Info_Params_Proc; + + procedure Info_Locals_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Decls : Iir; + begin + -- From statement to declaration. + Decl := Get_Source_Scope (Current_Instance); + loop + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Generate_Statement_Body => + Decls := Get_Declaration_Chain (Decl); + exit; + when Iir_Kind_While_Loop_Statement + | Iir_Kind_If_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Case_Statement => + Decl := Get_Parent (Decl); + when others => + Vhdl.Errors.Error_Kind ("info_params_proc", Decl); + end case; + end loop; + Disp_Declaration_Objects (Current_Instance, Decls); + end Info_Locals_Proc; + + procedure Info_Instance_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Debug_Synth_Instance (Current_Instance); + end Info_Instance_Proc; + + function Walk_Files (Cb : Walk_Cb) return Walk_Status + is + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + File : Iir_Design_File; + begin + while Lib /= Null_Iir loop + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + case Cb.all (File) is + when Walk_Continue => + null; + when Walk_Up => + exit; + when Walk_Abort => + return Walk_Abort; + end case; + File := Get_Chain (File); + end loop; + Lib := Get_Chain (Lib); + end loop; + return Walk_Continue; + end Walk_Files; + + Walk_Units_Cb : Walk_Cb; + + function Cb_Walk_Units (Design_File : Iir) return Walk_Status + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is + when Walk_Continue => + null; + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + exit; + end case; + Unit := Get_Chain (Unit); + end loop; + return Walk_Continue; + end Cb_Walk_Units; + + function Walk_Units (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Units_Cb := Cb; + return Walk_Files (Cb_Walk_Units'Access); + end Walk_Units; + + Walk_Declarations_Cb : Walk_Cb; + + function Cb_Walk_Declarations (Unit : Iir) return Walk_Status + is + function Walk_Decl_Chain (Chain : Iir) return Walk_Status + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Walk_Declarations_Cb.all (Decl) is + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + return Walk_Continue; + when Walk_Continue => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return Walk_Continue; + end Walk_Decl_Chain; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status; + + function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is + begin + if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then + return Walk_Abort; + end if; + if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort + then + return Walk_Abort; + end if; + return Walk_Continue; + end Walk_Generate_Statement_Body; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status + is + Stmt : Iir := Chain; + begin + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kinds_Process_Statement => + if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) + = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_For_Generate_Statement => + if Walk_Declarations_Cb.all + (Get_Parameter_Specification (Stmt)) = Walk_Abort + or else Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_If_Generate_Statement => + declare + Stmt1 : Iir; + begin + Stmt1 := Stmt; + while Stmt1 /= Null_Iir loop + if Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + Stmt1 := Get_Generate_Else_Clause (Stmt1); + end loop; + end; + when Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Concurrent_Simple_Signal_Assignment => + null; + when Iir_Kind_Block_Statement => + -- FIXME: header + if (Walk_Decl_Chain + (Get_Declaration_Chain (Stmt)) = Walk_Abort) + or else + (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) + then + return Walk_Abort; + end if; + when others => + Vhdl.Errors.Error_Kind ("walk_conc_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + return Walk_Continue; + end Walk_Conc_Chain; + begin + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort + or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort + or else (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Architecture_Body => + if (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_Configuration_Declaration => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + -- FIXME: block configuration ? + when Iir_Kind_Context_Declaration => + null; + when others => + Vhdl.Errors.Error_Kind ("Cb_Walk_Declarations", Unit); + end case; + return Walk_Continue; + end Cb_Walk_Declarations; + + function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Declarations_Cb := Cb; + return Walk_Units (Cb_Walk_Declarations'Access); + end Walk_Declarations; + + -- Next statement in the same frame, but handle compound statements as + -- one statement. + procedure Next_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Current_Instance; + Exec_Statement := Current_Loc; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Next_Stmt_Proc; + + -- Finish parent statement. + procedure Finish_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Current_Instance; + Exec_Statement := Get_Parent (Current_Loc); + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Finish_Stmt_Proc; + + procedure Next_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next; + Exec_Instance := Current_Instance; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Next_Proc'Access; + end Next_Proc; + + procedure Step_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Single_Step; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Step_Proc'Access; + end Step_Proc; + + Break_Id : Name_Id; + + procedure Set_Breakpoint (Stmt : Iir) is + begin + Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); + Breakpoints.Append (Stmt); + Flag_Need_Debug := True; + end Set_Breakpoint; + + function Cb_Set_Break (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Identifier (El) = Break_Id + and then + Get_Implicit_Definition (El) not in Iir_Predefined_Implicit + then + Set_Breakpoint + (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); + end if; + when others => + null; + end case; + return Walk_Continue; + end Cb_Set_Break; + + procedure Break_Proc (Line : String) + is + Status : Walk_Status; + P : Natural; + begin + P := Skip_Blanks (Line); + if Line (P) = '"' then + -- An operator name. + declare + use Str_Table; + Str : String8_Id; + Len : Nat32; + begin + Str := Create_String8; + Len := 0; + P := P + 1; + while Line (P) /= '"' loop + Append_String8_Char (Line (P)); + Len := Len + 1; + P := P + 1; + end loop; + Break_Id := Vhdl.Parse.Str_To_Operator_Name + (Str, Len, No_Location); + -- FIXME: free string. + -- FIXME: catch error. + end; + else + Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); + end if; + Status := Walk_Declarations (Cb_Set_Break'Access); + pragma Assert (Status = Walk_Continue); + end Break_Proc; + + procedure Help_Proc (Line : String); + + procedure Prepare_Continue is + begin + Command_Status := Status_Quit; + + -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. + Flag_Need_Debug := False; + for I in Breakpoints.First .. Breakpoints.Last loop + Flag_Need_Debug := True; + exit; + end loop; + end Prepare_Continue; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Prepare_Continue; + end Cont_Proc; + + procedure List_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Disp_Current_Lines; + end List_Proc; + + Menu_Info_Instance : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("inst*ance"), + Next => null, -- Menu_Info_Tree'Access, + Proc => Info_Instance_Proc'Access); + + Menu_Info_Locals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("locals"), + Next => Menu_Info_Instance'Access, + Proc => Info_Locals_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Locals'Access, -- Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => new String'("i*nfo"), + Next => null, -- Menu_Ps'Access, + First | Last => Menu_Info_Params'Access); -- Menu_Info_Proc'Access); + + Menu_List : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("l*list"), + Next => Menu_Info'Access, -- null, + Proc => List_Proc'Access); + + Menu_Cont : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("c*ont"), + Next => Menu_List'Access, --Menu_Print'Access, + Proc => Cont_Proc'Access); + + Menu_Nstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ns*tmt"), + Next => Menu_Cont'Access, -- Menu_Up'Access, + Proc => Next_Stmt_Proc'Access); + + Menu_Fstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("fs*tmt"), + Next => Menu_Nstmt'Access, + Proc => Finish_Stmt_Proc'Access); + + Menu_Next : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("n*ext"), + Next => Menu_Fstmt'Access, + Proc => Next_Proc'Access); + + Menu_Step : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("s*tep"), + Next => Menu_Next'Access, + Proc => Step_Proc'Access); + + Menu_Break : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("b*reak"), + Next => Menu_Step'Access, + Proc => Break_Proc'Access); + + Menu_Help2 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("?"), + Next => Menu_Break'Access, -- Menu_Help1'Access, + Proc => Help_Proc'Access); + + Menu_Top : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => null, + Next => null, + First | Last => Menu_Help2'Access); + + + function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) + return Menu_Entry_Acc + is + function Is_Cmd (Cmd_Name : String; Str : String) return Boolean + is + -- Number of characters that were compared. + P : Natural; + begin + P := 0; + -- Prefix (before the '*'). + loop + if P = Cmd_Name'Length then + -- Full match. + return P = Str'Length; + end if; + exit when Cmd_Name (Cmd_Name'First + P) = '*'; + if P = Str'Length then + -- Command is too short + return False; + end if; + if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + -- Suffix (after the '*') + loop + if P = Str'Length then + return True; + end if; + if P + 1 = Cmd_Name'Length then + -- String is too long + return False; + end if; + if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + end Is_Cmd; + Ent : Menu_Entry_Acc; + begin + Ent := Menu.First; + while Ent /= null loop + if Is_Cmd (Ent.Name.all, Cmd) then + return Ent; + end if; + Ent := Ent.Next; + end loop; + return null; + end Find_Menu; + + procedure Parse_Command (Line : String; + P : in out Natural; + Menu : out Menu_Entry_Acc) + is + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + return; + end if; + E := Get_Word (Line (P .. Line'Last)); + Menu := Find_Menu (Menu, Line (P .. E)); + if Menu = null then + Put_Line ("command '" & Line (P .. E) & "' not found"); + end if; + P := E + 1; + end Parse_Command; + + procedure Help_Proc (Line : String) + is + P : Natural; + Root : Menu_Entry_Acc := Menu_Top'access; + begin + Put_Line ("This is the help command"); + P := Line'First; + while P < Line'Last loop + Parse_Command (Line, P, Root); + if Root = null then + return; + elsif Root.Kind /= Menu_Submenu then + Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); + return; + end if; + end loop; + + Root := Root.First; + while Root /= null loop + Put (Root.Name.all); + if Root.Kind = Menu_Submenu then + Put (" (menu)"); + end if; + New_Line; + Root := Root.Next; + end loop; + end Help_Proc; + + procedure Debug (Reason: Debug_Reason) + is + use Grt.Readline; + Raw_Line : Char_Ptr; + Prompt : System.Address; + begin + Prompt := Prompt_Debug'Address; + + case Reason is + when Reason_Init => + Prompt := Prompt_Init'Address; + when Reason_Error => + Prompt := Prompt_Error'Address; + when Reason_Break => + case Exec_State is + when Exec_Run => + if not Is_Breakpoint_Hit then + return; + end if; + Put_Line ("breakpoint hit"); + when Exec_Single_Step => + null; + when Exec_Next => + if Current_Instance /= Exec_Instance then + return; + end if; + when Exec_Next_Stmt => + if Current_Instance /= Exec_Instance + or else Is_Within_Statement (Exec_Statement, Current_Loc) + then + return; + end if; + end case; + -- Default state. + Exec_State := Exec_Run; + + end case; + + case Reason is + when Reason_Error + | Reason_Break => + Put ("stopped at: "); + Disp_Iir_Location (Current_Loc); + New_Line; + Disp_Source_Line (Get_Location (Current_Loc)); + when others => + null; + end case; + + if Current_Loc /= Null_Node then + Set_List_Current (Get_Location (Current_Loc)); + end if; + + Command_Status := Status_Default; + + loop + loop + Raw_Line := Readline (Prompt); + -- Skip empty lines + if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then + if Cmd_Repeat /= null then + Cmd_Repeat.all (""); + case Command_Status is + when Status_Default => + null; + when Status_Quit => + return; + end case; + end if; + else + Cmd_Repeat := null; + exit; + end if; + end loop; + declare + Line_Last : constant Natural := Strlen (Raw_Line); + Line : String renames Raw_Line (1 .. Line_Last); + P, E : Positive; + Cmd : Menu_Entry_Acc := Menu_Top'Access; + begin + -- Find command + P := 1; + loop + E := P; + Parse_Command (Line, E, Cmd); + exit when Cmd = null; + case Cmd.Kind is + when Menu_Submenu => + if E > Line_Last then + Put_Line ("missing command for submenu " + & Line (P .. E - 1)); + Cmd := null; + exit; + end if; + P := E; + when Menu_Command => + exit; + end case; + end loop; + + if Cmd /= null then + Cmd.Proc.all (Line (E .. Line_Last)); + + case Command_Status is + when Status_Default => + null; + when Status_Quit => + exit; + end case; + end if; + exception + when Command_Error => + null; + end; + end loop; + -- Put ("resuming"); + end Debug; + + procedure Debug_Init (Top : Node) is + begin + Flag_Enabled := True; + + Current_Instance := null; + Current_Loc := Top; + + -- To avoid warnings. + Exec_Statement := Null_Node; + Exec_Instance := null; + + Debug (Reason_Init); + end Debug_Init; + + procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is + begin + Current_Instance := Inst; + Current_Loc := Stmt; + + Debug (Reason_Break); + end Debug_Break; + + procedure Debug_Leave (Inst : Synth_Instance_Acc) is + begin + if Exec_Instance = Inst then + -- Will be destroyed. + Exec_Instance := null; + + case Exec_State is + when Exec_Run => + null; + when Exec_Single_Step => + null; + when Exec_Next + | Exec_Next_Stmt => + -- Leave the frame, will stop just after. + Exec_State := Exec_Single_Step; + end case; + end if; + end Debug_Leave; + + procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is + begin + if Flag_Enabled then + Current_Instance := Inst; + Current_Loc := Expr; + Debug (Reason_Error); + end if; + end Debug_Error; +end Elab.Debugger; diff --git a/src/synth/elab-memtype.adb b/src/synth/elab-memtype.adb new file mode 100644 index 000000000..382378c1c --- /dev/null +++ b/src/synth/elab-memtype.adb @@ -0,0 +1,117 @@ +-- Values in 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 System; use System; +with System.Storage_Elements; + +package body Elab.Memtype is + + function "+" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr + is + use System.Storage_Elements; + begin + return To_Memory_Ptr (To_Address (Base) + Storage_Offset (Off)); + end "+"; + + type Ghdl_U8_Ptr is access all Ghdl_U8; + function To_U8_Ptr is + new Ada.Unchecked_Conversion (Address, Ghdl_U8_Ptr); + + procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8) is + begin + To_U8_Ptr (To_Address (Mem)).all := Val; + end Write_U8; + + function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8 is + begin + return To_U8_Ptr (To_Address (Mem)).all; + end Read_U8; + + procedure Write_I32 (Mem : Memory_Ptr; Val : Ghdl_I32) + is + V : Ghdl_I32; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + V := Val; + end Write_I32; + + function Read_I32 (Mem : Memory_Ptr) return Ghdl_I32 + is + V : Ghdl_I32; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + return V; + end Read_I32; + + procedure Write_U32 (Mem : Memory_Ptr; Val : Ghdl_U32) + is + V : Ghdl_U32; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + V := Val; + end Write_U32; + + function Read_U32 (Mem : Memory_Ptr) return Ghdl_U32 + is + V : Ghdl_U32; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + return V; + end Read_U32; + + procedure Write_I64 (Mem : Memory_Ptr; Val : Ghdl_I64) + is + V : Ghdl_I64; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + V := Val; + end Write_I64; + + function Read_I64 (Mem : Memory_Ptr) return Ghdl_I64 + is + V : Ghdl_I64; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + return V; + end Read_I64; + + procedure Write_Fp64 (Mem : Memory_Ptr; Val : Fp64) + is + V : Fp64; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + V := Val; + end Write_Fp64; + + function Read_Fp64 (Mem : Memory_Ptr) return Fp64 + is + V : Fp64; + for V'Address use To_Address (Mem); + pragma Import (Ada, V); + begin + return V; + end Read_Fp64; + +end Elab.Memtype; diff --git a/src/synth/elab-memtype.ads b/src/synth/elab-memtype.ads new file mode 100644 index 000000000..2fc088d5e --- /dev/null +++ b/src/synth/elab-memtype.ads @@ -0,0 +1,58 @@ +-- Values in 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 System; +with Ada.Unchecked_Conversion; + +with Types; use Types; + +with Grt.Types; use Grt.Types; + +package Elab.Memtype is + type Memory_Element is mod 2**8; + type Memory_Array is array (Size_Type range <>) of Memory_Element; + + -- Thin pointer for a generic pointer. + type Memory_Ptr is access all Memory_Array (Size_Type); + pragma No_Strict_Aliasing (Memory_Ptr); + + -- For conversions use Address to avoid compiler warnings about alignment. + function To_Address is new Ada.Unchecked_Conversion + (Memory_Ptr, System.Address); + function To_Memory_Ptr is new Ada.Unchecked_Conversion + (System.Address, Memory_Ptr); + + -- Low-level functions. + + function "+" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr; + + procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8); + function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8; + + procedure Write_U32 (Mem : Memory_Ptr; Val : Ghdl_U32); + function Read_U32 (Mem : Memory_Ptr) return Ghdl_U32; + + procedure Write_I32 (Mem : Memory_Ptr; Val : Ghdl_I32); + function Read_I32 (Mem : Memory_Ptr) return Ghdl_I32; + + procedure Write_I64 (Mem : Memory_Ptr; Val : Ghdl_I64); + function Read_I64 (Mem : Memory_Ptr) return Ghdl_I64; + + procedure Write_Fp64 (Mem : Memory_Ptr; Val : Fp64); + function Read_Fp64 (Mem : Memory_Ptr) return Fp64; +end Elab.Memtype; diff --git a/src/synth/elab-vhdl_context-debug.adb b/src/synth/elab-vhdl_context-debug.adb new file mode 100644 index 000000000..13f615558 --- /dev/null +++ b/src/synth/elab-vhdl_context-debug.adb @@ -0,0 +1,73 @@ +-- Synthesis context. +-- Copyright (C) 2021 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 Simple_IO; use Simple_IO; +with Utils_IO; use Utils_IO; + +with Vhdl.Errors; +with Elab.Vhdl_Values.Debug; use Elab.Vhdl_Values.Debug; + +package body Elab.Vhdl_Context.Debug is + procedure Debug_Synth_Instance (Inst : Synth_Instance_Acc) is + begin + Put_Line ("instance for: " + & Vhdl.Errors.Disp_Node (Get_Source_Scope (Inst))); + for I in Inst.Objects'Range loop + Put_Uns32 (Uns32 (I)); + Put (": "); + case Inst.Objects (I).Kind is + when Obj_None => + Put_Line ("none"); + when Obj_Object => + Put ("object"); + Put (": "); + Debug_Valtyp (Inst.Objects (I).Obj); + when Obj_Subtype => + Put ("subtype"); + Put (": "); + Debug_Typ (Inst.Objects (I).T_Typ); + when Obj_Instance => + Put ("instance"); + New_Line; + end case; + end loop; + end Debug_Synth_Instance; + + procedure Debug_Elab_Tree_1 (Inst : Synth_Instance_Acc; Level : Natural) is + begin + Put_Indent (Level); + if Inst = null then + Put_Line ("*null*"); + return; + end if; + + Put_Line (Vhdl.Errors.Disp_Node (Get_Source_Scope (Inst))); + + for I in Inst.Objects'Range loop + if Inst.Objects (I).Kind = Obj_Instance then + Debug_Elab_Tree_1 (Inst.Objects (I).I_Inst, Level + 1); + end if; + end loop; + end Debug_Elab_Tree_1; + + procedure Debug_Elab_Tree (Inst : Synth_Instance_Acc) is + begin + Debug_Elab_Tree_1 (Inst, 0); + end Debug_Elab_Tree; +end Elab.Vhdl_Context.Debug; diff --git a/src/synth/elab-vhdl_context-debug.ads b/src/synth/elab-vhdl_context-debug.ads new file mode 100644 index 000000000..edc057fd3 --- /dev/null +++ b/src/synth/elab-vhdl_context-debug.ads @@ -0,0 +1,22 @@ +-- Synthesis context. +-- Copyright (C) 2021 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 . + +package Elab.Vhdl_Context.Debug is + procedure Debug_Synth_Instance (Inst : Synth_Instance_Acc); + procedure Debug_Elab_Tree (Inst : Synth_Instance_Acc); +end Elab.Vhdl_Context.Debug; diff --git a/src/synth/elab-vhdl_context.adb b/src/synth/elab-vhdl_context.adb new file mode 100644 index 000000000..7235ef04d --- /dev/null +++ b/src/synth/elab-vhdl_context.adb @@ -0,0 +1,514 @@ +-- Synthesis context. +-- Copyright (C) 2017 Tristan Gingold +-- +-- This file is part of GHDL. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +with Ada.Unchecked_Deallocation; + +with Types; use Types; +with Tables; + +with Vhdl.Errors; use Vhdl.Errors; +with Vhdl.Utils; + +package body Elab.Vhdl_Context is + + Sig_Nbr : Uns32 := 0; + + package Inst_Tables is new Tables + (Table_Component_Type => Synth_Instance_Acc, + Table_Index_Type => Instance_Id_Type, + Table_Low_Bound => First_Instance_Id, + Table_Initial => 16); + + function Get_Instance_Id (Inst : Synth_Instance_Acc) + return Instance_Id_Type is + begin + return Inst.Id; + end Get_Instance_Id; + + procedure Make_Root_Instance is + begin + -- Allow multiple elaborations + -- pragma Assert (Root_Instance = null); + + Root_Instance := + new Synth_Instance_Type'(Max_Objs => Global_Info.Nbr_Objects, + Is_Const => False, + Is_Error => False, + Id => Inst_Tables.Last + 1, + Block_Scope => Global_Info, + Up_Block => null, + Uninst_Scope => null, + Source_Scope => Null_Node, + Config => Null_Node, + Extra_Units => null, + Extra_Link => null, + Elab_Objects => 0, + Objects => (others => (Kind => Obj_None))); + Inst_Tables.Append (Root_Instance); + end Make_Root_Instance; + + procedure Free_Base_Instance is + begin + -- TODO: really free. + null; + end Free_Base_Instance; + + function Make_Elab_Instance + (Parent : Synth_Instance_Acc; Blk : Node; Config : Node) + return Synth_Instance_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Blk); + Scope : Sim_Info_Acc; + Res : Synth_Instance_Acc; + begin + if Get_Kind (Blk) = Iir_Kind_Architecture_Body then + -- Architectures are extensions of entities. + Scope := Get_Info (Vhdl.Utils.Get_Entity (Blk)); + else + Scope := Info; + end if; + + Res := new Synth_Instance_Type'(Max_Objs => Info.Nbr_Objects, + Is_Const => False, + Is_Error => False, + Id => Inst_Tables.Last + 1, + Block_Scope => Scope, + Up_Block => Parent, + Uninst_Scope => null, + Source_Scope => Blk, + Config => Config, + Extra_Units => null, + Extra_Link => null, + Elab_Objects => 0, + Objects => (others => + (Kind => Obj_None))); + Inst_Tables.Append (Res); + return Res; + end Make_Elab_Instance; + + procedure Free_Elab_Instance (Synth_Inst : in out Synth_Instance_Acc) + is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Synth_Instance_Type, Synth_Instance_Acc); + Id : constant Instance_Id_Type := Synth_Inst.Id; + begin + Deallocate (Synth_Inst); + if Id = Inst_Tables.Last then + Inst_Tables.Decrement_Last; + else + Inst_Tables.Table (Id) := null; + end if; + end Free_Elab_Instance; + + function Make_Elab_Generate_Instance + (Parent : Synth_Instance_Acc; Blk : Node; Config : Node; Len : Natural) + return Synth_Instance_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Blk); + Res : Synth_Instance_Acc; + begin + Res := new Synth_Instance_Type'(Max_Objs => Object_Slot_Type (Len), + Is_Const => False, + Is_Error => False, + Id => Inst_Tables.Last + 1, + Block_Scope => Info, + Up_Block => Parent, + Uninst_Scope => null, + Source_Scope => Blk, + Config => Config, + Extra_Units => null, + Extra_Link => null, + Elab_Objects => 0, + Objects => (others => + (Kind => Obj_None))); + Inst_Tables.Append (Res); + return Res; + end Make_Elab_Generate_Instance; + + function Get_Generate_Sub_Instance + (Parent : Synth_Instance_Acc; Idx : Positive) return Synth_Instance_Acc is + begin + return Parent.Objects (Object_Slot_Type (Idx)).I_Inst; + end Get_Generate_Sub_Instance; + + procedure Set_Generate_Sub_Instance + (Parent : Synth_Instance_Acc; Idx : Positive; Child : Synth_Instance_Acc) + is + begin + Parent.Objects (Object_Slot_Type (Idx)) := (Obj_Instance, Child); + end Set_Generate_Sub_Instance; + + function Is_Error (Inst : Synth_Instance_Acc) return Boolean is + begin + return Inst.Is_Error; + end Is_Error; + + procedure Set_Error (Inst : Synth_Instance_Acc) is + begin + Inst.Is_Error := True; + end Set_Error; + + function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node is + begin + return Inst.Source_Scope; + end Get_Source_Scope; + + function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean is + begin + return Inst.Is_Const; + end Get_Instance_Const; + + function Check_Set_Instance_Const (Inst : Synth_Instance_Acc) + return Boolean is + begin + for I in 1 .. Inst.Elab_Objects loop + if Inst.Objects (I).Kind /= Obj_Subtype then + return False; + end if; + end loop; + return True; + end Check_Set_Instance_Const; + + procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean) is + begin + pragma Assert (not Val or else Check_Set_Instance_Const (Inst)); + Inst.Is_Const := Val; + end Set_Instance_Const; + + procedure Set_Instance_Config (Inst : Synth_Instance_Acc; Config : Node) is + begin + pragma Assert (Inst.Config = Null_Node); + Inst.Config := Config; + end Set_Instance_Config; + + function Get_Instance_Config (Inst : Synth_Instance_Acc) return Node is + begin + return Inst.Config; + end Get_Instance_Config; + + procedure Add_Extra_Instance (Inst : Synth_Instance_Acc; + Extra : Synth_Instance_Acc) is + begin + pragma Assert (Extra.Extra_Link = null); + Extra.Extra_Link := Inst.Extra_Units; + Inst.Extra_Units := Extra; + end Add_Extra_Instance; + + function Get_First_Extra_Instance (Inst : Synth_Instance_Acc) + return Synth_Instance_Acc is + begin + return Inst.Extra_Units; + end Get_First_Extra_Instance; + + function Get_Next_Extra_Instance (Inst : Synth_Instance_Acc) + return Synth_Instance_Acc is + begin + return Inst.Extra_Link; + end Get_Next_Extra_Instance; + + procedure Create_Object (Syn_Inst : Synth_Instance_Acc; + Slot : Object_Slot_Type; + Num : Object_Slot_Type := 1) is + begin + -- Check elaboration order. + -- Note: this is not done for package since objects from package are + -- commons (same scope), and package annotation order can be different + -- from package elaboration order (eg: body). + if Slot /= Syn_Inst.Elab_Objects + 1 + or else Syn_Inst.Objects (Slot).Kind /= Obj_None + then + Error_Msg_Elab ("synth: bad elaboration order of objects"); + raise Internal_Error; + end if; + Syn_Inst.Elab_Objects := Slot + Num - 1; + end Create_Object; + + procedure Create_Object_Force + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + pragma Assert + (Syn_Inst.Objects (Info.Slot).Kind = Obj_None + or else Vt = (null, null) + or else Syn_Inst.Objects (Info.Slot) = (Kind => Obj_Object, + Obj => No_Valtyp)); + Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt); + end Create_Object_Force; + + procedure Create_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Create_Object (Syn_Inst, Info.Slot, 1); + Create_Object_Force (Syn_Inst, Decl, Vt); + end Create_Object; + + procedure Create_Signal (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Typ : Type_Acc; + Init : Value_Acc) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Vt : Valtyp; + begin + Create_Object (Syn_Inst, Info.Slot, 1); + Vt := (Typ, Create_Value_Signal (Sig_Nbr, Init)); + Sig_Nbr := Sig_Nbr + 1; + Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt); + end Create_Signal; + + procedure Replace_Signal + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Obj : Obj_Type renames Syn_Inst.Objects (Info.Slot); + begin + pragma Assert (Obj.Kind = Obj_Object); + pragma Assert (Obj.Obj.Typ = Vt.Typ); + pragma Assert (Obj.Obj.Val.Kind = Value_Signal); + + Obj.Obj := Vt; + + -- TODO: free old signal ? + end Replace_Signal; + + procedure Mutate_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Obj : Obj_Type renames Syn_Inst.Objects (Info.Slot); + begin + pragma Assert (Obj.Kind = Obj_Object); + pragma Assert (Obj.Obj.Typ = Vt.Typ); + + Obj.Obj := Vt; + end Mutate_Object; + + procedure Create_Sub_Instance (Syn_Inst : Synth_Instance_Acc; + Stmt : Node; + Sub_Inst : Synth_Instance_Acc) + is + Info : constant Sim_Info_Acc := Get_Info (Stmt); + begin + Create_Object (Syn_Inst, Info.Inst_Slot, 1); + pragma Assert (Syn_Inst.Objects (Info.Inst_Slot).Kind = Obj_None); + Syn_Inst.Objects (Info.Inst_Slot) := (Kind => Obj_Instance, + I_Inst => Sub_Inst); + end Create_Sub_Instance; + + procedure Create_Component_Instance (Syn_Inst : Synth_Instance_Acc; + Sub_Inst : Synth_Instance_Acc) + is + Slot : constant Object_Slot_Type := Syn_Inst.Max_Objs; + begin + pragma Assert (Slot > 0); + pragma Assert (Syn_Inst.Objects (Slot).Kind = Obj_None); + Create_Object (Syn_Inst, Slot, 1); + Syn_Inst.Objects (Slot) := (Kind => Obj_Instance, + I_Inst => Sub_Inst); + end Create_Component_Instance; + + procedure Create_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc) + is + pragma Assert (Typ /= null); + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Create_Object (Syn_Inst, Info.Slot, 1); + pragma Assert (Syn_Inst.Objects (Info.Slot).Kind = Obj_None); + Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Subtype, T_Typ => Typ); + end Create_Subtype_Object; + + procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc; + Is_Global : Boolean) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + if Is_Global then + pragma Assert (Syn_Inst.Objects (Info.Pkg_Slot).Kind = Obj_None); + pragma Assert (Syn_Inst.Up_Block = null); + null; + else + pragma Assert (Syn_Inst.Up_Block /= null); + Create_Object (Syn_Inst, Info.Slot, 1); + end if; + Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, + I_Inst => Inst); + end Create_Package_Object; + + procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + pragma Assert (Syn_Inst.Up_Block /= null); + Create_Object (Syn_Inst, Info.Pkg_Slot, 1); + Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, + I_Inst => Inst); + end Create_Package_Interface; + + function Get_Package_Object + (Syn_Inst : Synth_Instance_Acc; Info : Sim_Info_Acc) + return Synth_Instance_Acc + is + Parent : Synth_Instance_Acc; + begin + Parent := Get_Instance_By_Scope (Syn_Inst, Info.Pkg_Parent); + return Parent.Objects (Info.Pkg_Slot).I_Inst; + end Get_Package_Object; + + function Get_Package_Object + (Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc is + begin + return Get_Package_Object (Syn_Inst, Get_Info (Pkg)); + end Get_Package_Object; + + function Create_Package_Instance (Parent_Inst : Synth_Instance_Acc; + Pkg : Node) + return Synth_Instance_Acc + is + Syn_Inst : Synth_Instance_Acc; + begin + Syn_Inst := Make_Elab_Instance (Parent_Inst, Pkg, Null_Node); + if Get_Kind (Get_Parent (Pkg)) = Iir_Kind_Design_Unit then + -- Global package. + Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, True); + else + -- Local package: check elaboration order. + Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, False); + end if; + return Syn_Inst; + end Create_Package_Instance; + + function Get_Sub_Instance + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) return Synth_Instance_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Stmt); + begin + return Syn_Inst.Objects (Info.Inst_Slot).I_Inst; + end Get_Sub_Instance; + + function Get_Component_Instance + (Syn_Inst : Synth_Instance_Acc) return Synth_Instance_Acc + is + Slot : constant Object_Slot_Type := Syn_Inst.Max_Objs; + begin + return Syn_Inst.Objects (Slot).I_Inst; + end Get_Component_Instance; + + procedure Set_Uninstantiated_Scope + (Syn_Inst : Synth_Instance_Acc; Bod : Node) is + begin + Syn_Inst.Uninst_Scope := Get_Info (Bod); + end Set_Uninstantiated_Scope; + + procedure Destroy_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Slot : constant Object_Slot_Type := Info.Slot; + begin + if Slot /= Syn_Inst.Elab_Objects + or else Info.Obj_Scope /= Syn_Inst.Block_Scope + then + Error_Msg_Elab ("synth: bad destroy order"); + end if; + Syn_Inst.Objects (Slot) := (Kind => Obj_None); + Syn_Inst.Elab_Objects := Slot - 1; + end Destroy_Object; + + function Get_Instance_By_Scope + (Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc) + return Synth_Instance_Acc is + begin + case Scope.Kind is + when Kind_Block + | Kind_Frame + | Kind_Process => + declare + Current : Synth_Instance_Acc; + begin + Current := Syn_Inst; + while Current /= null loop + if Current.Block_Scope = Scope then + return Current; + end if; + Current := Current.Up_Block; + end loop; + raise Internal_Error; + end; + when Kind_Package => + if Scope.Pkg_Parent = null then + -- This is a scope for an uninstantiated package. + declare + Current : Synth_Instance_Acc; + begin + Current := Syn_Inst; + while Current /= null loop + if Current.Uninst_Scope = Scope then + return Current; + end if; + Current := Current.Up_Block; + end loop; + raise Internal_Error; + end; + else + -- Instantiated package. + return Get_Package_Object (Syn_Inst, Scope); + end if; + when others => + raise Internal_Error; + end case; + end Get_Instance_By_Scope; + + function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc + is + Parent : Node; + begin + Parent := Get_Parent (Blk); + if Get_Kind (Parent) = Iir_Kind_Architecture_Body then + Parent := Vhdl.Utils.Get_Entity (Parent); + end if; + return Get_Info (Parent); + end Get_Parent_Scope; + + function Get_Value (Syn_Inst: Synth_Instance_Acc; Obj : Node) + return Valtyp + is + Info : constant Sim_Info_Acc := Get_Info (Obj); + Obj_Inst : Synth_Instance_Acc; + begin + Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); + return Obj_Inst.Objects (Info.Slot).Obj; + end Get_Value; + + function Get_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Obj_Inst : Synth_Instance_Acc; + begin + Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); + return Obj_Inst.Objects (Info.Slot).T_Typ; + end Get_Subtype_Object; +end Elab.Vhdl_Context; diff --git a/src/synth/elab-vhdl_context.ads b/src/synth/elab-vhdl_context.ads new file mode 100644 index 000000000..2fc483c7f --- /dev/null +++ b/src/synth/elab-vhdl_context.ads @@ -0,0 +1,222 @@ +-- Synthesis context. +-- Copyright (C) 2017 Tristan Gingold +-- +-- This file is part of GHDL. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +with Vhdl.Annotations; use Vhdl.Annotations; +with Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + +package Elab.Vhdl_Context is + -- Values are stored into Synth_Instance, which is parallel to simulation + -- Block_Instance_Type. + + type Synth_Instance_Type (<>) is limited private; + type Synth_Instance_Acc is access Synth_Instance_Type; + + Root_Instance : Synth_Instance_Acc; + + -- Unique per instance id. Used to create parallel tables. + type Instance_Id_Type is new Natural; + First_Instance_Id : constant Instance_Id_Type := 1; + + function Get_Instance_Id (Inst : Synth_Instance_Acc) + return Instance_Id_Type; + pragma Inline (Get_Instance_Id); + + function Get_Instance_By_Scope + (Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc) + return Synth_Instance_Acc; + + -- Create the root instance (which contains the packages). + -- Assign ROOT_INSTANCE. + procedure Make_Root_Instance; + + -- Free the first instance. + procedure Free_Base_Instance; + + -- Create and free the corresponding synth instance. + function Make_Elab_Instance + (Parent : Synth_Instance_Acc; Blk : Node; Config : Node) + return Synth_Instance_Acc; + + procedure Free_Elab_Instance (Synth_Inst : in out Synth_Instance_Acc); + + function Make_Elab_Generate_Instance + (Parent : Synth_Instance_Acc; Blk : Node; Config : Node; Len : Natural) + return Synth_Instance_Acc; + + function Get_Generate_Sub_Instance + (Parent : Synth_Instance_Acc; Idx : Positive) return Synth_Instance_Acc; + procedure Set_Generate_Sub_Instance + (Parent : Synth_Instance_Acc; Idx : Positive; Child : Synth_Instance_Acc); + + function Is_Error (Inst : Synth_Instance_Acc) return Boolean; + pragma Inline (Is_Error); + + procedure Set_Error (Inst : Synth_Instance_Acc); + + function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean; + procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean); + + -- Get the corresponding source for the scope of the instance. + function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node; + + procedure Set_Instance_Config (Inst : Synth_Instance_Acc; Config : Node); + function Get_Instance_Config (Inst : Synth_Instance_Acc) return Node; + + -- Add/Get extra instances. + -- Those instances are verification units. + procedure Add_Extra_Instance (Inst : Synth_Instance_Acc; + Extra : Synth_Instance_Acc); + function Get_First_Extra_Instance (Inst : Synth_Instance_Acc) + return Synth_Instance_Acc; + function Get_Next_Extra_Instance (Inst : Synth_Instance_Acc) + return Synth_Instance_Acc; + + procedure Create_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); + + procedure Create_Signal (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Typ : Type_Acc; + Init : Value_Acc); + + -- Create a sub instance: either a direct entity instantiation, or + -- a component instantiation. + procedure Create_Sub_Instance (Syn_Inst : Synth_Instance_Acc; + Stmt : Node; + Sub_Inst : Synth_Instance_Acc); + + -- Create a sub instance for a component. + procedure Create_Component_Instance (Syn_Inst : Synth_Instance_Acc; + Sub_Inst : Synth_Instance_Acc); + + procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc; + Is_Global : Boolean); + + function Create_Package_Instance (Parent_Inst : Synth_Instance_Acc; + Pkg : Node) + return Synth_Instance_Acc; + + procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Inst : Synth_Instance_Acc); + + procedure Create_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc); + + -- Force the value of DECL, without checking for elaboration order. + -- It is for deferred constants. + procedure Create_Object_Force + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); + + procedure Replace_Signal + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); + procedure Mutate_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); + + procedure Destroy_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node); + + -- Get the value of OBJ. + function Get_Value (Syn_Inst : Synth_Instance_Acc; Obj : Node) + return Valtyp; + + function Get_Package_Object + (Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc; + + -- Return the type for DECL (a subtype indication). + function Get_Subtype_Object + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc; + + function Get_Sub_Instance + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) return Synth_Instance_Acc; + function Get_Component_Instance + (Syn_Inst : Synth_Instance_Acc) return Synth_Instance_Acc; + + -- Return the scope of the parent of BLK. Deals with architecture bodies. + function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc; + + procedure Set_Uninstantiated_Scope + (Syn_Inst : Synth_Instance_Acc; Bod : Node); +private + type Obj_Kind is + ( + Obj_None, + Obj_Object, + Obj_Subtype, + Obj_Instance + ); + + type Obj_Type (Kind : Obj_Kind := Obj_None) is record + case Kind is + when Obj_None => + null; + when Obj_Object => + Obj : Valtyp; + when Obj_Subtype => + T_Typ : Type_Acc; + when Obj_Instance => + I_Inst : Synth_Instance_Acc; + end case; + end record; + + type Objects_Array is array (Object_Slot_Type range <>) of Obj_Type; + + type Synth_Instance_Type (Max_Objs : Object_Slot_Type) is limited record + Is_Const : Boolean; + + -- True if a fatal error has been detected that aborts the synthesis + -- of this instance. + Is_Error : Boolean; + + Id : Instance_Id_Type; + + -- The corresponding info for this instance. + -- This is used for lookup. + Block_Scope : Sim_Info_Acc; + + -- The corresponding info the the uninstantiated specification of + -- an instantiated package. When an object is looked for from the + -- uninstantiated body, the scope of the uninstantiated specification + -- is used. And it is different from Block_Scope. + -- This is used for lookup of uninstantiated specification. + Uninst_Scope : Sim_Info_Acc; + + -- Instance of the parent scope. + Up_Block : Synth_Instance_Acc; + + -- Source construct corresponding to this instance. + Source_Scope : Node; + + -- Block configuration (unless the instance is for a package). + Config : Node; + + -- Chain of verification units that applies to this one. + Extra_Units : Synth_Instance_Acc; + Extra_Link : Synth_Instance_Acc; + + Elab_Objects : Object_Slot_Type; + + -- Instance for synthesis. + Objects : Objects_Array (1 .. Max_Objs); + end record; +end Elab.Vhdl_Context; diff --git a/src/synth/elab-vhdl_decls.adb b/src/synth/elab-vhdl_decls.adb new file mode 100644 index 000000000..6c4091afd --- /dev/null +++ b/src/synth/elab-vhdl_decls.adb @@ -0,0 +1,361 @@ +-- Create declarations for 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 Vhdl.Errors; use Vhdl.Errors; +with Vhdl.Utils; use Vhdl.Utils; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Vhdl_Files; +with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; +with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; + +package body Elab.Vhdl_Decls is + procedure Elab_Subprogram_Declaration + (Syn_Inst : Synth_Instance_Acc; Subprg : Node) + is + Inter : Node; + begin + if Is_Second_Subprogram_Specification (Subprg) then + -- Already handled. + return; + end if; + + Inter := Get_Interface_Declaration_Chain (Subprg); + while Inter /= Null_Node loop + Elab_Declaration_Type (Syn_Inst, Inter); + Inter := Get_Chain (Inter); + end loop; + end Elab_Subprogram_Declaration; + + procedure Elab_Constant_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Last_Type : in out Node) + is + Deferred_Decl : constant Node := Get_Deferred_Declaration (Decl); + First_Decl : Node; + Decl_Type : Node; + Val : Valtyp; + Obj_Type : Type_Acc; + begin + Elab_Declaration_Type (Syn_Inst, Decl); + if Deferred_Decl = Null_Node + or else Get_Deferred_Declaration_Flag (Decl) + then + -- Create the object (except for full declaration of a + -- deferred constant). + Create_Object (Syn_Inst, Decl, No_Valtyp); + end if; + -- Initialize the value (except for a deferred declaration). + if Get_Deferred_Declaration_Flag (Decl) then + return; + end if; + if Deferred_Decl = Null_Node then + -- A normal constant declaration + First_Decl := Decl; + else + -- The full declaration of a deferred constant. + First_Decl := Deferred_Decl; + end if; + pragma Assert (First_Decl /= Null_Node); + + -- Use the type of the declaration. The type of the constant may + -- be derived from the value. + -- FIXME: what about multiple declarations ? + Decl_Type := Get_Subtype_Indication (Decl); + if Decl_Type = Null_Node then + Decl_Type := Last_Type; + else + if Get_Kind (Decl_Type) in Iir_Kinds_Denoting_Name then + -- Type mark. + Decl_Type := Get_Type (Get_Named_Entity (Decl_Type)); + end if; + Last_Type := Decl_Type; + end if; + Obj_Type := Get_Subtype_Object (Syn_Inst, Decl_Type); + Val := Exec_Expression_With_Type + (Syn_Inst, Get_Default_Value (Decl), Obj_Type); + if Val = No_Valtyp then + Set_Error (Syn_Inst); + return; + end if; + Val := Exec_Subtype_Conversion (Val, Obj_Type, True, Decl); + Create_Object_Force (Syn_Inst, First_Decl, Val); + end Elab_Constant_Declaration; + + procedure Elab_Signal_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node) + is + Def : constant Iir := Get_Default_Value (Decl); + Init : Valtyp; + Obj_Typ : Type_Acc; + begin + Elab_Declaration_Type (Syn_Inst, Decl); + Obj_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Decl)); + + if Is_Valid (Def) then + Init := Exec_Expression_With_Type (Syn_Inst, Def, Obj_Typ); + Init := Exec_Subtype_Conversion (Init, Obj_Typ, False, Decl); + else + Init := No_Valtyp; + end if; + Create_Signal (Syn_Inst, Decl, Obj_Typ, Init.Val); + end Elab_Signal_Declaration; + + procedure Elab_Variable_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node) + is + Def : constant Node := Get_Default_Value (Decl); + Decl_Type : constant Node := Get_Type (Decl); + Init : Valtyp; + Obj_Typ : Type_Acc; + begin + Elab_Declaration_Type (Syn_Inst, Decl); + if Get_Kind (Decl_Type) = Iir_Kind_Protected_Type_Declaration then + Error_Msg_Elab (+Decl, "protected type not supported"); + return; + end if; + Obj_Typ := Get_Subtype_Object (Syn_Inst, Decl_Type); + + if Is_Valid (Def) then + Init := Exec_Expression_With_Type (Syn_Inst, Def, Obj_Typ); + Init := Exec_Subtype_Conversion (Init, Obj_Typ, False, Decl); + else + Init := No_Valtyp; + end if; + Create_Object (Syn_Inst, Decl, Init); + end Elab_Variable_Declaration; + + procedure Elab_File_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node) + is + F : File_Index; + Res : Valtyp; + Obj_Typ : Type_Acc; + begin + F := Elab.Vhdl_Files.Elaborate_File_Declaration (Syn_Inst, Decl); + Obj_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Decl)); + Res := Create_Value_File (Obj_Typ, F); + Create_Object (Syn_Inst, Decl, Res); + end Elab_File_Declaration; + + procedure Elab_Attribute_Specification + (Syn_Inst : Synth_Instance_Acc; Spec : Node) + is + Attr_Decl : constant Node := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + Value : Node; + Val : Valtyp; + Val_Type : Type_Acc; + begin + Val_Type := Get_Subtype_Object (Syn_Inst, Get_Type (Attr_Decl)); + Value := Get_Attribute_Value_Spec_Chain (Spec); + while Value /= Null_Iir loop + -- 2. The expression is evaluated to determine the value + -- of the attribute. + -- It is an error if the value of the expression does not + -- belong to the subtype of the attribute; if the + -- attribute is of an array type, then an implicit + -- subtype conversion is first performed on the value, + -- unless the attribute's subtype indication denotes an + -- unconstrained array type. + Val := Exec_Expression_With_Type + (Syn_Inst, Get_Expression (Spec), Val_Type); + -- Check_Constraints (Instance, Val, Attr_Type, Decl); + + -- 3. A new instance of the designated attribute is created + -- and associated with each of the affected items. + -- + -- 4. Each new attribute instance is assigned the value of + -- the expression. + Create_Object (Syn_Inst, Value, Val); + -- Unshare (Val, Instance_Pool); + + Value := Get_Spec_Chain (Value); + end loop; + end Elab_Attribute_Specification; + + procedure Elab_Object_Alias_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) + is + Atype : constant Node := Get_Declaration_Type (Decl); + Off : Value_Offsets; + Res : Valtyp; + Obj_Typ : Type_Acc; + Base : Valtyp; + Typ : Type_Acc; + begin + -- Subtype indication may not be present. + if Atype /= Null_Node then + Synth_Subtype_Indication (Syn_Inst, Atype); + Obj_Typ := Get_Subtype_Object (Syn_Inst, Atype); + else + Obj_Typ := null; + end if; + + Exec_Assignment_Prefix (Syn_Inst, Get_Name (Decl), Base, Typ, Off); + Res := Create_Value_Alias (Base, Off, Typ); + if Obj_Typ /= null then + Res := Exec_Subtype_Conversion (Res, Obj_Typ, True, Decl); + end if; + Create_Object (Syn_Inst, Decl, Res); + end Elab_Object_Alias_Declaration; + + procedure Elab_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Last_Type : in out Node) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Variable_Declaration => + Elab_Variable_Declaration (Syn_Inst, Decl); + -- when Iir_Kind_Interface_Variable_Declaration => + -- -- Ignore default value. + -- Create_Wire_Object (Syn_Inst, Wire_Variable, Decl); + -- Create_Var_Wire (Syn_Inst, Decl, No_Valtyp); + when Iir_Kind_Constant_Declaration => + Elab_Constant_Declaration (Syn_Inst, Decl, Last_Type); + when Iir_Kind_Signal_Declaration => + Elab_Signal_Declaration (Syn_Inst, Decl); + when Iir_Kind_Object_Alias_Declaration => + Elab_Object_Alias_Declaration (Syn_Inst, Decl); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + Elab_Subprogram_Declaration (Syn_Inst, Decl); + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Attribute_Declaration => + -- Nothing to do: the type is a type_mark, not a subtype + -- indication. + null; + when Iir_Kind_Attribute_Specification => + Elab_Attribute_Specification (Syn_Inst, Decl); + when Iir_Kind_Type_Declaration => + Elab_Type_Definition (Syn_Inst, Get_Type_Definition (Decl)); + when Iir_Kind_Anonymous_Type_Declaration => + Elab_Anonymous_Type_Definition + (Syn_Inst, Get_Type_Definition (Decl), + Get_Subtype_Definition (Decl)); + when Iir_Kind_Subtype_Declaration => + Elab_Declaration_Type (Syn_Inst, Decl); + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_File_Declaration => + Elab_File_Declaration (Syn_Inst, Decl); + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Psl_Default_Clock => + -- Ignored; directly used by PSL directives. + null; + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Signal_Attribute_Declaration => + -- Not supported by synthesis. + null; + when others => + Vhdl.Errors.Error_Kind ("elab_declaration", Decl); + end case; + end Elab_Declaration; + + procedure Elab_Declarations (Syn_Inst : Synth_Instance_Acc; Decls : Iir) + is + Decl : Node; + Last_Type : Node; + begin + Last_Type := Null_Node; + Decl := Decls; + while Is_Valid (Decl) loop + Elab_Declaration (Syn_Inst, Decl, Last_Type); + + exit when Is_Error (Syn_Inst); + + Decl := Get_Chain (Decl); + end loop; + end Elab_Declarations; + + procedure Finalize_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node; Is_Subprg : Boolean) + is + pragma Unreferenced (Syn_Inst); + begin + case Get_Kind (Decl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + null; + when Iir_Kind_Constant_Declaration => + null; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + pragma Assert (not Is_Subprg); + null; + when Iir_Kind_Object_Alias_Declaration => + null; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + null; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Attribute_Specification => + null; + when Iir_Kind_Type_Declaration => + null; + when Iir_Kind_Anonymous_Type_Declaration => + null; + when Iir_Kind_Subtype_Declaration => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_File_Declaration => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Psl_Default_Clock => + -- Ignored; directly used by PSL directives. + null; + when Iir_Kind_Signal_Attribute_Declaration => + -- Not supported by synthesis. + null; + when others => + Vhdl.Errors.Error_Kind ("finalize_declaration", Decl); + end case; + end Finalize_Declaration; + + procedure Finalize_Declarations (Syn_Inst : Synth_Instance_Acc; + Decls : Iir; + Is_Subprg : Boolean := False) + is + Decl : Iir; + begin + Decl := Decls; + while Is_Valid (Decl) loop + Finalize_Declaration (Syn_Inst, Decl, Is_Subprg); + + Decl := Get_Chain (Decl); + end loop; + end Finalize_Declarations; +end Elab.Vhdl_Decls; diff --git a/src/synth/elab-vhdl_decls.ads b/src/synth/elab-vhdl_decls.ads new file mode 100644 index 000000000..5937e1f58 --- /dev/null +++ b/src/synth/elab-vhdl_decls.ads @@ -0,0 +1,40 @@ +-- Create declarations for 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 Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Context; use Elab.Vhdl_Context; + +package Elab.Vhdl_Decls is + procedure Elab_Subprogram_Declaration + (Syn_Inst : Synth_Instance_Acc; Subprg : Node); + + procedure Elab_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Last_Type : in out Node); + + procedure Elab_Declarations (Syn_Inst : Synth_Instance_Acc; Decls : Iir); + + procedure Finalize_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Iir; + Is_Subprg : Boolean); + procedure Finalize_Declarations (Syn_Inst : Synth_Instance_Acc; + Decls : Iir; + Is_Subprg : Boolean := False); + +end Elab.Vhdl_Decls; diff --git a/src/synth/elab-vhdl_errors.adb b/src/synth/elab-vhdl_errors.adb new file mode 100644 index 000000000..827f73a17 --- /dev/null +++ b/src/synth/elab-vhdl_errors.adb @@ -0,0 +1,58 @@ +-- Error handling for 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 . + +package body Elab.Vhdl_Errors is + procedure Error_Msg_Elab (Loc : Location_Type; + Msg : String; + Arg1 : Earg_Type) is + begin + Report_Msg (Msgid_Error, Errorout.Elaboration, + +Loc, Msg, (1 => Arg1)); + end Error_Msg_Elab; + + procedure Error_Msg_Elab (Loc : Location_Type; + Msg : String; + Args : Earg_Arr := No_Eargs) is + begin + Report_Msg (Msgid_Error, Errorout.Elaboration, + +Loc, Msg, Args); + end Error_Msg_Elab; + + -- 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; + + -- procedure Info_Msg_Synth (Loc : Location_Type; + -- Msg : String; + -- Args : Earg_Arr := No_Eargs) is + -- begin + -- Report_Msg (Msgid_Note, Errorout.Elaboration, +Loc, Msg, Args); + -- end Info_Msg_Synth; + +end Elab.Vhdl_Errors; diff --git a/src/synth/elab-vhdl_errors.ads b/src/synth/elab-vhdl_errors.ads new file mode 100644 index 000000000..d4cd19a24 --- /dev/null +++ b/src/synth/elab-vhdl_errors.ads @@ -0,0 +1,38 @@ +-- Error handling for 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 Errorout; use Errorout; + +package Elab.Vhdl_Errors is + procedure Error_Msg_Elab (Loc : Location_Type; + Msg : String; + Arg1 : Earg_Type); + procedure Error_Msg_Elab (Loc : Location_Type; + 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); + -- procedure Info_Msg_Synth (Loc : Location_Type; + -- Msg : String; + -- Args : Earg_Arr := No_Eargs); +end Elab.Vhdl_Errors; diff --git a/src/synth/elab-vhdl_expr.adb b/src/synth/elab-vhdl_expr.adb new file mode 100644 index 000000000..35a92c39d --- /dev/null +++ b/src/synth/elab-vhdl_expr.adb @@ -0,0 +1,1402 @@ +-- 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 Name_Table; +with Std_Names; +with Str_Table; +with Errorout; use Errorout; + +with Vhdl.Errors; use Vhdl.Errors; +with Vhdl.Utils; use Vhdl.Utils; +with Vhdl.Evaluation; use Vhdl.Evaluation; +with Vhdl.Annotations; use Vhdl.Annotations; + +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 Elab.Debugger; + +with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; +with Synth.Vhdl_Oper; use Synth.Vhdl_Oper; +with Synth.Vhdl_Aggr; + +with Grt.Types; +with Grt.To_Strings; + +package body Elab.Vhdl_Expr is + function Get_Value_Memtyp (V : Valtyp) return Memtyp is + begin + case V.Val.Kind is + when Value_Memory => + return (V.Typ, V.Val.Mem); + when Value_Const => + return Get_Memtyp (V); + when Value_Alias => + declare + Res : Memtyp; + begin + Res := Get_Value_Memtyp ((V.Val.A_Typ, V.Val.A_Obj)); + return (V.Typ, Res.Mem + V.Val.A_Off.Mem_Off); + end; + when others => + raise Internal_Error; + end case; + end Get_Value_Memtyp; + + function Get_Static_Discrete (V : Valtyp) return Int64 is + begin + case V.Val.Kind is + when Value_Memory => + return Read_Discrete (V); + when Value_Const => + return Read_Discrete (Get_Memtyp (V)); + when others => + raise Internal_Error; + end case; + end Get_Static_Discrete; + + function Synth_Array_Bounds (Syn_Inst : Synth_Instance_Acc; + Atype : Node; + Dim : Dim_Type) return Bound_Type + is + Info : constant Sim_Info_Acc := Get_Info (Atype); + begin + if Info = null then + pragma Assert (Get_Type_Declarator (Atype) = Null_Node); + declare + Index_Type : constant Node := + Get_Index_Type (Atype, Natural (Dim - 1)); + begin + return Synth_Bounds_From_Range (Syn_Inst, Index_Type); + end; + else + declare + Bnds : constant Type_Acc := Get_Subtype_Object (Syn_Inst, Atype); + begin + case Bnds.Kind is + when Type_Vector => + pragma Assert (Dim = 1); + return Bnds.Vbound; + when Type_Array => + return Bnds.Abounds.D (Dim); + when others => + raise Internal_Error; + end case; + end; + end if; + end Synth_Array_Bounds; + + 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 Synth_Simple_Aggregate (Syn_Inst : Synth_Instance_Acc; + Aggr : Node) return Valtyp + is + Aggr_Type : constant Node := Get_Type (Aggr); + pragma Assert (Get_Nbr_Dimensions (Aggr_Type) = 1); + El_Type : constant Node := Get_Element_Subtype (Aggr_Type); + El_Typ : constant Type_Acc := Get_Subtype_Object (Syn_Inst, El_Type); + Els : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); + Last : constant Natural := Flist_Last (Els); + Bnd : Bound_Type; + Bnds : Bound_Array_Acc; + Res_Type : Type_Acc; + Val : Valtyp; + Res : Valtyp; + begin + -- Allocate the result. + Bnd := Synth_Array_Bounds (Syn_Inst, Aggr_Type, 1); + pragma Assert (Bnd.Len = Uns32 (Last + 1)); + + if El_Typ.Kind in Type_Nets then + Res_Type := Create_Vector_Type (Bnd, El_Typ); + else + Bnds := Create_Bound_Array (1); + Bnds.D (1) := Bnd; + Res_Type := Create_Array_Type (Bnds, El_Typ); + end if; + + Res := Create_Value_Memory (Res_Type); + + for I in Flist_First .. Last loop + -- Elements are supposed to be static, so no need for enable. + Val := Exec_Expression_With_Type + (Syn_Inst, Get_Nth_Element (Els, I), El_Typ); + pragma Assert (Is_Static (Val.Val)); + Write_Value (Res.Val.Mem + Size_Type (I) * El_Typ.Sz, Val); + end loop; + + return Res; + end Synth_Simple_Aggregate; + + -- Change the bounds of VAL. + function Reshape_Value (Val : Valtyp; Ntype : Type_Acc) return Valtyp is + begin + case Val.Val.Kind is + when Value_Alias => + return Create_Value_Alias + ((Val.Val.A_Typ, Val.Val.A_Obj), Val.Val.A_Off, Ntype); + when Value_Const => + return Reshape_Value ((Val.Typ, Val.Val.C_Val), Ntype); + when Value_Memory => + return (Ntype, Val.Val); + when others => + raise Internal_Error; + end case; + end Reshape_Value; + + function Exec_Subtype_Conversion (Vt : Valtyp; + Dtype : Type_Acc; + Bounds : Boolean; + Loc : Node) + return Valtyp + is + Vtype : constant Type_Acc := Vt.Typ; + begin + if Vt = No_Valtyp then + -- Propagate error. + return No_Valtyp; + end if; + if Dtype = Vtype then + return Vt; + end if; + + case Dtype.Kind is + when Type_Bit => + pragma Assert (Vtype.Kind = Type_Bit); + return Vt; + when Type_Logic => + pragma Assert (Vtype.Kind = Type_Logic); + return Vt; + when Type_Discrete => + pragma Assert (Vtype.Kind in Type_All_Discrete); + case Vt.Val.Kind is + when Value_Net + | Value_Wire + | Value_Alias => + raise Internal_Error; + when Value_Const => + return Exec_Subtype_Conversion + ((Vt.Typ, Vt.Val.C_Val), Dtype, Bounds, Loc); + when Value_Memory => + -- Check for overflow. + declare + Val : constant Int64 := Read_Discrete (Vt); + begin + if not In_Range (Dtype.Drange, Val) then + Error_Msg_Elab (+Loc, "value out of range"); + return No_Valtyp; + end if; + return Create_Value_Discrete (Val, Dtype); + end; + when others => + raise Internal_Error; + end case; + when Type_Float => + pragma Assert (Vtype.Kind = Type_Float); + -- TODO: check range + return Vt; + when Type_Vector => + pragma Assert (Vtype.Kind = Type_Vector + or Vtype.Kind = Type_Slice); + if Dtype.W /= Vtype.W then + Error_Msg_Elab + (+Loc, "mismatching vector length; got %v, expect %v", + (+Vtype.W, +Dtype.W)); + return No_Valtyp; + end if; + if Bounds then + return Reshape_Value (Vt, Dtype); + else + return Vt; + end if; + when Type_Slice => + -- TODO: check width + return Vt; + when Type_Array => + pragma Assert (Vtype.Kind = Type_Array); + -- Check bounds. + for I in Vtype.Abounds.D'Range loop + if Vtype.Abounds.D (I).Len /= Dtype.Abounds.D (I).Len then + Error_Msg_Elab (+Loc, "mismatching array bounds"); + return No_Valtyp; + end if; + end loop; + -- TODO: check element. + if Bounds then + return Reshape_Value (Vt, Dtype); + else + return Vt; + end if; + when Type_Unbounded_Array => + pragma Assert (Vtype.Kind = Type_Array); + return Vt; + when Type_Unbounded_Vector => + pragma Assert (Vtype.Kind = Type_Vector + or else Vtype.Kind = Type_Slice); + return Vt; + when Type_Record => + pragma Assert (Vtype.Kind = Type_Record); + -- TODO: handle elements. + return Vt; + when Type_Unbounded_Record => + pragma Assert (Vtype.Kind = Type_Record); + return Vt; + when Type_Access => + return Vt; + when Type_File + | Type_Protected => + -- No conversion expected. + -- As the subtype is identical, it is already handled by the + -- above check. + raise Internal_Error; + end case; + end Exec_Subtype_Conversion; + + function Synth_Value_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) + return Valtyp + is + Param : constant Node := Get_Parameter (Attr); + Etype : constant Node := Get_Type (Attr); + Btype : constant Node := Get_Base_Type (Etype); + V : Valtyp; + Dtype : Type_Acc; + begin + -- The value is supposed to be static. + V := Exec_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; + + declare + Str : constant String := Value_To_String (V); + Res_N : Node; + Val : Int64; + begin + case Get_Kind (Btype) is + when Iir_Kind_Enumeration_Type_Definition => + Res_N := Eval_Value_Attribute (Str, Etype, Attr); + Val := Int64 (Get_Enum_Pos (Res_N)); + Free_Iir (Res_N); + when Iir_Kind_Integer_Type_Definition => + Val := Int64'Value (Str); + when others => + Error_Msg_Elab (+Attr, "unhandled type for 'value"); + return No_Valtyp; + end case; + return Create_Value_Discrete (Val, Dtype); + end; + end Synth_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 ("execute_image_attribute", Expr_Type); + end case; + end Synth_Image_Attribute_Str; + + function String_To_Valtyp (Str : String; Styp : Type_Acc) return Valtyp + is + Len : constant Natural := Str'Length; + Bnd : Bound_Array_Acc; + Typ : Type_Acc; + Res : Valtyp; + begin + Bnd := Create_Bound_Array (1); + Bnd.D (1) := (Dir => Dir_To, Left => 1, Right => Int32 (Len), + Len => Uns32 (Len)); + Typ := Create_Array_Type (Bnd, Styp.Uarr_El); + + Res := Create_Value_Memory (Typ); + for I in Str'Range loop + Write_U8 (Res.Val.Mem + Size_Type (I - Str'First), + Character'Pos (Str (I))); + end loop; + return Res; + end String_To_Valtyp; + + function Synth_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; + begin + -- The parameter is expected to be static. + V := Exec_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); + return String_To_Valtyp + (Synth_Image_Attribute_Str (V, Get_Type (Param)), Dtype); + end Synth_Image_Attribute; + + function Synth_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); + begin + -- Return a truncated name, as the prefix is not completly known. + return String_To_Valtyp (Name.Suffix, Atyp); + end Synth_Instance_Name_Attribute; + + -- Convert index IDX in PFX to an offset. + -- SYN_INST and LOC are used in case of error. + function Index_To_Offset + (Syn_Inst : Synth_Instance_Acc; Bnd : Bound_Type; Idx : Int64; Loc : Node) + return Value_Offsets + is + Res : Value_Offsets; + begin + if not In_Bounds (Bnd, Int32 (Idx)) then + Error_Msg_Elab (+Loc, "index not within bounds"); + Elab.Debugger.Debug_Error (Syn_Inst, Loc); + return (0, 0); + end if; + + -- The offset is from the LSB (bit 0). Bit 0 is the rightmost one. + case Bnd.Dir is + when Dir_To => + Res.Net_Off := Uns32 (Bnd.Right - Int32 (Idx)); + Res.Mem_Off := Size_Type (Int32 (Idx) - Bnd.Left); + when Dir_Downto => + Res.Net_Off := Uns32 (Int32 (Idx) - Bnd.Right); + Res.Mem_Off := Size_Type (Bnd.Left - Int32 (Idx)); + end case; + + return Res; + end Index_To_Offset; + + -- 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_Vector => + El_Typ := Typ.Vec_El; + Bnd := Typ.Vbound; + when Type_Array => + El_Typ := Typ.Arr_El; + Bnd := Typ.Abounds.D (1); + when others => + raise Internal_Error; + end case; + end Get_Onedimensional_Array_Bounds; + + function Create_Onedimensional_Array_Subtype + (Btyp : Type_Acc; Bnd : Bound_Type) return Type_Acc + is + Res : Type_Acc; + Bnds : Bound_Array_Acc; + begin + case Btyp.Kind is + when Type_Vector => + Res := Create_Vector_Type (Bnd, Btyp.Vec_El); + when Type_Unbounded_Vector => + Res := Create_Vector_Type (Bnd, Btyp.Uvec_El); + when Type_Array => + pragma Assert (Btyp.Abounds.Ndim = 1); + Bnds := Create_Bound_Array (1); + Bnds.D (1) := Bnd; + Res := Create_Array_Type (Bnds, Btyp.Arr_El); + when Type_Unbounded_Array => + pragma Assert (Btyp.Uarr_Ndim = 1); + Bnds := Create_Bound_Array (1); + Bnds.D (1) := Bnd; + Res := Create_Array_Type (Bnds, Btyp.Uarr_El); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Onedimensional_Array_Subtype; + + procedure Exec_Indexed_Name (Syn_Inst : Synth_Instance_Acc; + Name : Node; + Pfx_Type : Type_Acc; + Off : out Value_Offsets) + is + Indexes : constant Iir_Flist := Get_Index_List (Name); + El_Typ : constant Type_Acc := Get_Array_Element (Pfx_Type); + Idx_Expr : Node; + Idx_Val : Valtyp; + Bnd : Bound_Type; + Stride : Uns32; + Idx_Off : Value_Offsets; + begin + Off := (0, 0); + + Stride := 1; + for I in reverse Flist_First .. Flist_Last (Indexes) loop + Idx_Expr := Get_Nth_Element (Indexes, I); + + -- Use the base type as the subtype of the index is not synth-ed. + Idx_Val := Exec_Expression_With_Basetype (Syn_Inst, Idx_Expr); + if Idx_Val = No_Valtyp then + -- Propagate errorc + Off := (0, 0); + return; + end if; + + Strip_Const (Idx_Val); + + Bnd := Get_Array_Bound (Pfx_Type, Dim_Type (I + 1)); + + pragma Assert (Is_Static (Idx_Val.Val)); + + Idx_Off := Index_To_Offset (Syn_Inst, Bnd, + Get_Static_Discrete (Idx_Val), Name); + Off.Net_Off := Off.Net_Off + Idx_Off.Net_Off * Stride * El_Typ.W; + Off.Mem_Off := Off.Mem_Off + + Idx_Off.Mem_Off * Size_Type (Stride) * El_Typ.Sz; + + Stride := Stride * Bnd.Len; + end loop; + end Exec_Indexed_Name; + + procedure Exec_Slice_Const_Suffix (Syn_Inst: Synth_Instance_Acc; + Expr : Node; + Name : Node; + Pfx_Bnd : Bound_Type; + L, R : Int64; + Dir : Direction_Type; + El_Typ : Type_Acc; + Res_Bnd : out Bound_Type; + Off : out Value_Offsets) + is + Is_Null : Boolean; + Len : Uns32; + begin + if Pfx_Bnd.Dir /= Dir then + Error_Msg_Elab (+Name, "direction mismatch in slice"); + Off := (0, 0); + if Dir = Dir_To then + Res_Bnd := (Dir => Dir_To, Left => 1, Right => 0, Len => 0); + else + Res_Bnd := (Dir => Dir_Downto, Left => 0, Right => 1, Len => 0); + end if; + return; + end if; + + -- Might be a null slice. + case Pfx_Bnd.Dir is + when Dir_To => + Is_Null := L > R; + when Dir_Downto => + Is_Null := L < R; + end case; + if Is_Null then + Len := 0; + Off := (0, 0); + else + if not In_Bounds (Pfx_Bnd, Int32 (L)) + or else not In_Bounds (Pfx_Bnd, Int32 (R)) + then + Error_Msg_Elab (+Name, "index not within bounds"); + Elab.Debugger.Debug_Error (Syn_Inst, Expr); + Off := (0, 0); + return; + end if; + + case Pfx_Bnd.Dir is + when Dir_To => + Len := Uns32 (R - L + 1); + Off.Net_Off := Uns32 (Pfx_Bnd.Right - Int32 (R)) * El_Typ.W; + Off.Mem_Off := Size_Type (Int32 (L) - Pfx_Bnd.Left) * El_Typ.Sz; + when Dir_Downto => + Len := Uns32 (L - R + 1); + Off.Net_Off := Uns32 (Int32 (R) - Pfx_Bnd.Right) * El_Typ.W; + Off.Mem_Off := Size_Type (Pfx_Bnd.Left - Int32 (L)) * El_Typ.Sz; + end case; + end if; + Res_Bnd := (Dir => Pfx_Bnd.Dir, + Len => Len, + Left => Int32 (L), + Right => Int32 (R)); + end Exec_Slice_Const_Suffix; + + procedure Exec_Slice_Suffix (Syn_Inst : Synth_Instance_Acc; + Name : Node; + Pfx_Bnd : Bound_Type; + El_Typ : Type_Acc; + Res_Bnd : out Bound_Type; + Off : out Value_Offsets) + is + Expr : constant Node := Get_Suffix (Name); + Left, Right : Valtyp; + Dir : Direction_Type; + begin + Off := (0, 0); + + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + -- As the range may be dynamic, cannot use synth_discrete_range. + Left := Exec_Expression_With_Basetype + (Syn_Inst, Get_Left_Limit (Expr)); + Right := Exec_Expression_With_Basetype + (Syn_Inst, Get_Right_Limit (Expr)); + Dir := Get_Direction (Expr); + + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kinds_Denoting_Name => + declare + Rng : Discrete_Range_Type; + begin + Synth_Discrete_Range (Syn_Inst, Expr, Rng); + Exec_Slice_Const_Suffix (Syn_Inst, Expr, + Name, Pfx_Bnd, + Rng.Left, Rng.Right, Rng.Dir, + El_Typ, Res_Bnd, Off); + return; + end; + when others => + Error_Msg_Elab + (+Expr, "only range expression supported for slices"); + Res_Bnd := (Dir => Dir_To, Left => 1, Right => 0, Len => 0); + return; + end case; + + pragma Assert (Is_Static (Left.Val)); + pragma Assert (Is_Static (Right.Val)); + Exec_Slice_Const_Suffix (Syn_Inst, Expr, + Name, Pfx_Bnd, + Get_Static_Discrete (Left), + Get_Static_Discrete (Right), + Dir, + El_Typ, Res_Bnd, Off); + end Exec_Slice_Suffix; + + function Exec_Name (Syn_Inst : Synth_Instance_Acc; Name : Node) + return Valtyp is + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Exec_Name (Syn_Inst, Get_Named_Entity (Name)); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration => + return Get_Value (Syn_Inst, Name); + when Iir_Kind_Enumeration_Literal => + declare + Typ : constant Type_Acc := + Get_Subtype_Object (Syn_Inst, Get_Type (Name)); + Res : Valtyp; + begin + Res := Create_Value_Memory (Typ); + Write_Discrete (Res, Int64 (Get_Enum_Pos (Name))); + return Res; + end; + when Iir_Kind_Unit_Declaration => + declare + Typ : constant Type_Acc := + Get_Subtype_Object (Syn_Inst, Get_Type (Name)); + begin + return Create_Value_Discrete + (Vhdl.Evaluation.Get_Physical_Value (Name), Typ); + end; + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + declare + Val : Valtyp; + begin + Val := Exec_Expression (Syn_Inst, Get_Prefix (Name)); + return Elab.Vhdl_Heap.Synth_Dereference (Read_Access (Val)); + end; + when others => + Error_Kind ("synth_name", Name); + end case; + end Exec_Name; + + procedure Exec_Assignment_Prefix (Syn_Inst : Synth_Instance_Acc; + Pfx : Node; + Dest_Base : out Valtyp; + Dest_Typ : out Type_Acc; + Dest_Off : out Value_Offsets) is + begin + case Get_Kind (Pfx) is + when Iir_Kind_Simple_Name => + Exec_Assignment_Prefix (Syn_Inst, Get_Named_Entity (Pfx), + Dest_Base, Dest_Typ, Dest_Off); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration => + declare + Targ : constant Valtyp := Get_Value (Syn_Inst, Pfx); + begin + Dest_Typ := Targ.Typ; + + if Targ.Val.Kind = Value_Alias then + -- Replace alias by the aliased name. + Dest_Base := (Targ.Val.A_Typ, Targ.Val.A_Obj); + Dest_Off := Targ.Val.A_Off; + else + Dest_Base := Targ; + Dest_Off := (0, 0); + end if; + end; + + when Iir_Kind_Indexed_Name => + declare + Off : Value_Offsets; + begin + Exec_Assignment_Prefix + (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off); + Strip_Const (Dest_Base); + Exec_Indexed_Name (Syn_Inst, Pfx, Dest_Typ, Off); + + Dest_Off := Dest_Off + Off; + Dest_Typ := Get_Array_Element (Dest_Typ); + end; + + when Iir_Kind_Selected_Element => + declare + Idx : constant Iir_Index32 := + Get_Element_Position (Get_Named_Entity (Pfx)); + begin + Exec_Assignment_Prefix + (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off); + Dest_Off.Net_Off := + Dest_Off.Net_Off + Dest_Typ.Rec.E (Idx + 1).Boff; + Dest_Off.Mem_Off := + Dest_Off.Mem_Off + Dest_Typ.Rec.E (Idx + 1).Moff; + + Dest_Typ := Dest_Typ.Rec.E (Idx + 1).Typ; + end; + + when Iir_Kind_Slice_Name => + declare + Pfx_Bnd : Bound_Type; + El_Typ : Type_Acc; + Res_Bnd : Bound_Type; + Sl_Off : Value_Offsets; + begin + Exec_Assignment_Prefix + (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off); + Strip_Const (Dest_Base); + + Get_Onedimensional_Array_Bounds (Dest_Typ, Pfx_Bnd, El_Typ); + Exec_Slice_Suffix (Syn_Inst, Pfx, Pfx_Bnd, El_Typ, + Res_Bnd, Sl_Off); + + -- Fixed slice. + Dest_Typ := Create_Onedimensional_Array_Subtype + (Dest_Typ, Res_Bnd); + Dest_Off.Net_Off := Dest_Off.Net_Off + Sl_Off.Net_Off; + Dest_Off.Mem_Off := Dest_Off.Mem_Off + Sl_Off.Mem_Off; + end; + + when others => + Error_Kind ("exec_assignment_prefix", Pfx); + end case; + end Exec_Assignment_Prefix; + + -- Return the type of EXPR without evaluating it. + function Exec_Type_Of_Object (Syn_Inst : Synth_Instance_Acc; Expr : Node) + return Type_Acc is + begin + case Get_Kind (Expr) is + when Iir_Kinds_Object_Declaration => + declare + Val : constant Valtyp := Get_Value (Syn_Inst, Expr); + begin + return Val.Typ; + end; + when Iir_Kind_Simple_Name => + return Exec_Type_Of_Object (Syn_Inst, Get_Named_Entity (Expr)); + when Iir_Kind_Slice_Name => + declare + Pfx_Typ : Type_Acc; + Pfx_Bnd : Bound_Type; + El_Typ : Type_Acc; + Res_Bnd : Bound_Type; + Sl_Off : Value_Offsets; + begin + Pfx_Typ := Exec_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); + Get_Onedimensional_Array_Bounds (Pfx_Typ, Pfx_Bnd, El_Typ); + Exec_Slice_Suffix (Syn_Inst, Expr, Pfx_Bnd, El_Typ, + Res_Bnd, Sl_Off); + return Create_Onedimensional_Array_Subtype (Pfx_Typ, Res_Bnd); + end; + when Iir_Kind_Indexed_Name => + declare + Pfx_Typ : Type_Acc; + begin + Pfx_Typ := Exec_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); + return Get_Array_Element (Pfx_Typ); + end; + when Iir_Kind_Selected_Element => + declare + Idx : constant Iir_Index32 := + Get_Element_Position (Get_Named_Entity (Expr)); + Pfx_Typ : Type_Acc; + begin + Pfx_Typ := Exec_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); + return Pfx_Typ.Rec.E (Idx + 1).Typ; + end; + + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + declare + Val : Valtyp; + Res : Valtyp; + begin + -- Maybe do not dereference it if its type is known ? + Val := Exec_Expression (Syn_Inst, Get_Prefix (Expr)); + Res := Elab.Vhdl_Heap.Synth_Dereference (Read_Access (Val)); + return Res.Typ; + end; + + when Iir_Kind_String_Literal8 => + -- TODO: the value should be computed (once) and its type + -- returned. + return Synth_Subtype_Indication (Syn_Inst, Get_Type (Expr)); + + when others => + Vhdl.Errors.Error_Kind ("synth_type_of_object", Expr); + end case; + return null; + end Exec_Type_Of_Object; + + function Exec_Type_Conversion + (Syn_Inst : Synth_Instance_Acc; Conv : Node) return Valtyp + is + Expr : constant Node := Get_Expression (Conv); + Conv_Type : constant Node := Get_Type (Conv); + Conv_Typ : constant Type_Acc := Get_Subtype_Object (Syn_Inst, Conv_Type); + Val : Valtyp; + begin + Val := Exec_Expression_With_Basetype (Syn_Inst, Expr); + if Val = No_Valtyp then + return No_Valtyp; + end if; + Strip_Const (Val); + case Get_Kind (Conv_Type) is + when Iir_Kind_Integer_Subtype_Definition => + if Val.Typ.Kind = Type_Discrete then + -- Int to int. + return Val; + elsif Val.Typ.Kind = Type_Float then + return Create_Value_Discrete + (Int64 (Read_Fp64 (Val)), Conv_Typ); + else + Error_Msg_Elab (+Conv, "unhandled type conversion (to int)"); + return No_Valtyp; + end if; + when Iir_Kind_Floating_Subtype_Definition => + if Is_Static (Val.Val) then + return Create_Value_Float + (Fp64 (Read_Discrete (Val)), Conv_Typ); + else + Error_Msg_Elab (+Conv, "unhandled type conversion (to float)"); + return No_Valtyp; + end if; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + case Conv_Typ.Kind is + when Type_Vector + | Type_Unbounded_Vector => + return Val; + when others => + Error_Msg_Elab + (+Conv, "unhandled type conversion (to array)"); + return No_Valtyp; + end case; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + pragma Assert (Get_Base_Type (Get_Type (Expr)) + = Get_Base_Type (Conv_Type)); + return Val; + when others => + Error_Msg_Elab (+Conv, "unhandled type conversion"); + return No_Valtyp; + end case; + end Exec_Type_Conversion; + + function Error_Ieee_Operator (Imp : Node; Loc : Node) return Boolean + is + use Std_Names; + Parent : constant Iir := Get_Parent (Imp); + begin + if Get_Kind (Parent) = Iir_Kind_Package_Declaration + and then (Get_Identifier + (Get_Library (Get_Design_File (Get_Design_Unit (Parent)))) + = Name_Ieee) + then + case Get_Identifier (Parent) is + when Name_Std_Logic_1164 + | Name_Std_Logic_Arith + | Name_Std_Logic_Signed + | Name_Std_Logic_Unsigned + | Name_Std_Logic_Misc + | Name_Numeric_Std + | Name_Numeric_Bit + | Name_Math_Real => + Error_Msg_Elab + (+Loc, "unhandled predefined IEEE operator %i", +Imp); + Error_Msg_Elab + (+Imp, " declared here"); + return True; + when others => + -- ieee 2008 packages are handled like regular packages. + null; + end case; + end if; + + return False; + end Error_Ieee_Operator; + + function Synth_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); + + Str_Type : constant Node := Get_Type (Str); + El_Type : Type_Acc; + Bounds : Bound_Type; + Bnds : Bound_Array_Acc; + Res_Type : Type_Acc; + Res : Valtyp; + Pos : Nat8; + begin + case Str_Typ.Kind is + when Type_Vector => + Bounds := Str_Typ.Vbound; + when Type_Array => + Bounds := Str_Typ.Abounds.D (1); + when Type_Unbounded_Vector + | Type_Unbounded_Array => + Bounds := Synth_Bounds_From_Length + (Get_Index_Type (Str_Type, 0), Get_String_Length (Str)); + when others => + raise Internal_Error; + end case; + + El_Type := Get_Subtype_Object (Syn_Inst, Get_Element_Subtype (Str_Type)); + if El_Type.Kind in Type_Nets then + Res_Type := Create_Vector_Type (Bounds, El_Type); + else + Bnds := Create_Bound_Array (1); + Bnds.D (1) := Bounds; + Res_Type := Create_Array_Type (Bnds, El_Type); + end if; + Res := Create_Value_Memory (Res_Type); + + -- 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 Synth_String_Literal; + + -- Return the left bound if the direction of the range is LEFT_DIR. + function Synth_Low_High_Type_Attribute + (Syn_Inst : Synth_Instance_Acc; Expr : Node; Left_Dir : Direction_Type) + return Valtyp + is + Typ : Type_Acc; + R : Int64; + begin + Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Get_Prefix (Expr))); + pragma Assert (Typ.Kind = Type_Discrete); + if Typ.Drange.Dir = Left_Dir then + R := Typ.Drange.Left; + else + R := Typ.Drange.Right; + end if; + return Create_Value_Discrete (R, Typ); + end Synth_Low_High_Type_Attribute; + + function Exec_Short_Circuit (Syn_Inst : Synth_Instance_Acc; + Val : Int64; + Left_Expr : Node; + Right_Expr : Node; + Typ : Type_Acc) return Valtyp + is + Left : Valtyp; + Right : Valtyp; + begin + Left := Exec_Expression_With_Type (Syn_Inst, Left_Expr, Typ); + if Left = No_Valtyp then + -- Propagate error. + return No_Valtyp; + end if; + pragma Assert (Is_Static (Left.Val)); + if Get_Static_Discrete (Left) = Val then + -- Short-circuit when the left operand determines the result. + return Create_Value_Discrete (Val, Typ); + end if; + + Strip_Const (Left); + Right := Exec_Expression_With_Type (Syn_Inst, Right_Expr, Typ); + if Right = No_Valtyp then + -- Propagate error. + return No_Valtyp; + end if; + Strip_Const (Right); + + pragma Assert (Is_Static (Right.Val)); + if Get_Static_Discrete (Right) = Val then + -- If the right operand can determine the result, return it. + return Create_Value_Discrete (Val, Typ); + end if; + + -- Return a static value if both operands are static. + -- Note: we know the value of left if it is not constant. + return Create_Value_Discrete (Get_Static_Discrete (Right), Typ); + end Exec_Short_Circuit; + + function Exec_Expression_With_Type (Syn_Inst : Synth_Instance_Acc; + Expr : Node; + Expr_Type : Type_Acc) return Valtyp is + begin + case Get_Kind (Expr) is + when Iir_Kinds_Dyadic_Operator => + declare + Imp : constant Node := Get_Implementation (Expr); + Def : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + begin + -- Specially handle short-circuit operators. + case Def is + when Iir_Predefined_Boolean_And => + return Exec_Short_Circuit + (Syn_Inst, 0, Get_Left (Expr), Get_Right (Expr), + Boolean_Type); + when Iir_Predefined_Boolean_Or => + return Exec_Short_Circuit + (Syn_Inst, 1, Get_Left (Expr), Get_Right (Expr), + Boolean_Type); + when Iir_Predefined_Bit_And => + return Exec_Short_Circuit + (Syn_Inst, 0, Get_Left (Expr), Get_Right (Expr), + Bit_Type); + when Iir_Predefined_Bit_Or => + return Exec_Short_Circuit + (Syn_Inst, 1, Get_Left (Expr), Get_Right (Expr), + Bit_Type); + when Iir_Predefined_None => + if Error_Ieee_Operator (Imp, Expr) then + return No_Valtyp; + else + return Synth_User_Operator + (Syn_Inst, Get_Left (Expr), Get_Right (Expr), Expr); + end if; + when others => + return Synth_Dyadic_Operation + (Syn_Inst, Imp, + Get_Left (Expr), Get_Right (Expr), Expr); + end case; + end; + when Iir_Kinds_Monadic_Operator => + declare + Imp : constant Node := Get_Implementation (Expr); + Def : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + begin + if Def = Iir_Predefined_None then + if Error_Ieee_Operator (Imp, Expr) then + return No_Valtyp; + else + return Synth_User_Operator + (Syn_Inst, Get_Operand (Expr), Null_Node, Expr); + end if; + else + return Synth_Monadic_Operation + (Syn_Inst, Imp, Get_Operand (Expr), Expr); + end if; + end; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Interface_Signal_Declaration -- For PSL. + | Iir_Kind_Signal_Declaration -- For PSL. + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + declare + Res : Valtyp; + begin + Res := Exec_Name (Syn_Inst, Expr); + if Res.Val.Kind = Value_Signal then + Vhdl_Errors.Error_Msg_Elab + (+Expr, "cannot use signal value during elaboration"); + return No_Valtyp; + end if; + if Res.Typ /= null + and then Res.Typ.W = 0 and then Res.Val.Kind /= Value_Memory + then + -- This is a null object. As nothing can be done about it, + -- returns 0. + return Create_Value_Memtyp (Create_Memory_Zero (Res.Typ)); + end if; + return Res; + end; + when Iir_Kind_Reference_Name => + -- Only used for anonymous signals in internal association. + return Exec_Expression_With_Type + (Syn_Inst, Get_Named_Entity (Expr), Expr_Type); + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + raise Internal_Error; + -- declare + -- Base : Valtyp; + -- Typ : Type_Acc; + -- Off : Value_Offsets; + -- Res : Valtyp; + + -- Dyn : Dyn_Name; + -- begin + -- Synth_Assignment_Prefix (Syn_Inst, Expr, Base, Typ, Off, Dyn); + -- if Dyn.Voff = No_Net and then Is_Static (Base.Val) then + -- Res := Create_Value_Memory (Typ); + -- Copy_Memory + -- (Res.Val.Mem, Base.Val.Mem + Off.Mem_Off, Typ.Sz); + -- return Res; + -- end if; + -- return Synth_Read_Memory + -- (Syn_Inst, Base, Typ, Off.Net_Off, Dyn, Expr); + -- end; + when Iir_Kind_Selected_Element => + declare + Idx : constant Iir_Index32 := + Get_Element_Position (Get_Named_Entity (Expr)); + Pfx : constant Node := Get_Prefix (Expr); + Res_Typ : Type_Acc; + Val : Valtyp; + Res : Valtyp; + begin + Val := Exec_Expression (Syn_Inst, Pfx); + Strip_Const (Val); + Res_Typ := Val.Typ.Rec.E (Idx + 1).Typ; + if Res_Typ.W = 0 and then Val.Val.Kind /= Value_Memory then + -- This is a null object. As nothing can be done about it, + -- returns 0. + return Create_Value_Memtyp (Create_Memory_Zero (Res_Typ)); + end if; + pragma Assert (Is_Static (Val.Val)); + Res := Create_Value_Memory (Res_Typ); + Copy_Memory + (Res.Val.Mem, Val.Val.Mem + Val.Typ.Rec.E (Idx + 1).Moff, + Res_Typ.Sz); + return Res; + end; + when Iir_Kind_Character_Literal => + return Exec_Expression_With_Type + (Syn_Inst, Get_Named_Entity (Expr), Expr_Type); + when Iir_Kind_Integer_Literal => + declare + Res : Valtyp; + begin + Res := Create_Value_Memory (Expr_Type); + Write_Discrete (Res, Get_Value (Expr)); + return Res; + end; + when Iir_Kind_Floating_Point_Literal => + return Create_Value_Float (Get_Fp_Value (Expr), Expr_Type); + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return Create_Value_Discrete + (Get_Physical_Value (Expr), Expr_Type); + when Iir_Kind_String_Literal8 => + return Synth_String_Literal (Syn_Inst, Expr, Expr_Type); + when Iir_Kind_Enumeration_Literal => + return Exec_Name (Syn_Inst, Expr); + when Iir_Kind_Type_Conversion => + return Exec_Type_Conversion (Syn_Inst, Expr); + when Iir_Kind_Qualified_Expression => + return Exec_Expression_With_Type + (Syn_Inst, Get_Expression (Expr), + Get_Subtype_Object (Syn_Inst, Get_Type (Get_Type_Mark (Expr)))); + when Iir_Kind_Function_Call => + declare + Imp : constant Node := Get_Implementation (Expr); + begin + case Get_Implicit_Definition (Imp) is + when Iir_Predefined_Pure_Functions + | Iir_Predefined_Ieee_Numeric_Std_Binary_Operators => + return Synth_Operator_Function_Call (Syn_Inst, Expr); + when Iir_Predefined_None => + return Synth_User_Function_Call (Syn_Inst, Expr); + when others => + return Synth_Predefined_Function_Call (Syn_Inst, Expr); + end case; + end; + when Iir_Kind_Aggregate => + 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 => + return Exec_Expression_With_Type + (Syn_Inst, Get_Expression (Expr), Expr_Type); + when Iir_Kind_Left_Array_Attribute => + declare + B : Bound_Type; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + return Create_Value_Discrete (Int64 (B.Left), Expr_Type); + end; + when Iir_Kind_Right_Array_Attribute => + declare + B : Bound_Type; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + return Create_Value_Discrete (Int64 (B.Right), Expr_Type); + end; + when Iir_Kind_High_Array_Attribute => + declare + B : Bound_Type; + V : Int32; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + case B.Dir is + when Dir_To => + V := B.Right; + when Dir_Downto => + V := B.Left; + end case; + return Create_Value_Discrete (Int64 (V), Expr_Type); + end; + when Iir_Kind_Low_Array_Attribute => + declare + B : Bound_Type; + V : Int32; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + case B.Dir is + when Dir_To => + V := B.Left; + when Dir_Downto => + V := B.Right; + end case; + return Create_Value_Discrete (Int64 (V), Expr_Type); + end; + when Iir_Kind_Length_Array_Attribute => + declare + B : Bound_Type; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + return Create_Value_Discrete (Int64 (B.Len), Expr_Type); + end; + when Iir_Kind_Ascending_Array_Attribute => + declare + B : Bound_Type; + V : Int64; + begin + B := Synth_Array_Attribute (Syn_Inst, Expr); + case B.Dir is + when Dir_To => + V := 1; + when Dir_Downto => + V := 0; + end case; + return Create_Value_Discrete (V, Expr_Type); + end; + + when Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute => + declare + Param : constant Node := Get_Parameter (Expr); + V : Valtyp; + Dtype : Type_Acc; + begin + V := Exec_Expression (Syn_Inst, Param); + Dtype := Get_Subtype_Object (Syn_Inst, Get_Type (Expr)); + -- FIXME: to be generalized. Not always as simple as a + -- subtype conversion. + return Exec_Subtype_Conversion (V, Dtype, False, Expr); + end; + when Iir_Kind_Low_Type_Attribute => + return Synth_Low_High_Type_Attribute (Syn_Inst, Expr, Dir_To); + when Iir_Kind_High_Type_Attribute => + return Synth_Low_High_Type_Attribute (Syn_Inst, Expr, Dir_Downto); + when Iir_Kind_Value_Attribute => + return Synth_Value_Attribute (Syn_Inst, Expr); + when Iir_Kind_Image_Attribute => + return Synth_Image_Attribute (Syn_Inst, Expr); + when Iir_Kind_Instance_Name_Attribute => + return Synth_Instance_Name_Attribute (Syn_Inst, Expr); + when Iir_Kind_Null_Literal => + return Create_Value_Access (Null_Heap_Index, Expr_Type); + when Iir_Kind_Allocator_By_Subtype => + declare + T : Type_Acc; + Acc : Heap_Index; + begin + T := Synth_Subtype_Indication + (Syn_Inst, Get_Subtype_Indication (Expr)); + Acc := Allocate_By_Type (T); + return Create_Value_Access (Acc, Expr_Type); + end; + when Iir_Kind_Allocator_By_Expression => + declare + V : Valtyp; + Acc : Heap_Index; + begin + V := Exec_Expression_With_Type + (Syn_Inst, Get_Expression (Expr), Expr_Type.Acc_Acc); + Acc := Allocate_By_Value (V); + return Create_Value_Access (Acc, Expr_Type); + end; + when Iir_Kind_Stable_Attribute => + Error_Msg_Elab (+Expr, "signal attribute not supported"); + return No_Valtyp; + when Iir_Kind_Overflow_Literal => + Error_Msg_Elab (+Expr, "out of bound expression"); + return No_Valtyp; + when others => + Error_Kind ("exec_expression_with_type", Expr); + end case; + end Exec_Expression_With_Type; + + function Exec_Expression (Syn_Inst : Synth_Instance_Acc; Expr : Node) + return Valtyp + is + Etype : Node; + begin + Etype := Get_Type (Expr); + + case Get_Kind (Expr) is + when Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Integer_Literal => + -- The type of this attribute is the type of the index, which is + -- not synthesized as atype (only as an index). + -- For integer_literal, the type is not really needed, and it + -- may be created by static evaluation of an array attribute. + Etype := Get_Base_Type (Etype); + when others => + null; + end case; + + return Exec_Expression_With_Type + (Syn_Inst, Expr, Get_Subtype_Object (Syn_Inst, Etype)); + end Exec_Expression; + + function Exec_Expression_With_Basetype + (Syn_Inst : Synth_Instance_Acc; Expr : Node) return Valtyp + is + Basetype : Type_Acc; + begin + Basetype := Get_Subtype_Object + (Syn_Inst, Get_Base_Type (Get_Type (Expr))); + return Exec_Expression_With_Type (Syn_Inst, Expr, Basetype); + end Exec_Expression_With_Basetype; +end Elab.Vhdl_Expr; diff --git a/src/synth/elab-vhdl_expr.ads b/src/synth/elab-vhdl_expr.ads new file mode 100644 index 000000000..2eac33f1c --- /dev/null +++ b/src/synth/elab-vhdl_expr.ads @@ -0,0 +1,80 @@ +-- 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 Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + +package Elab.Vhdl_Expr is + -- For a static value V, return the value. + function Get_Static_Discrete (V : Valtyp) return Int64; + + -- Return the memory (as a memtyp) of static value V. + function Get_Value_Memtyp (V : Valtyp) return Memtyp; + + -- 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); + + -- Create an array subtype from bound BND. + function Create_Onedimensional_Array_Subtype + (Btyp : Type_Acc; Bnd : Bound_Type) return Type_Acc; + + -- Return the type of EXPR without evaluating it. + function Exec_Type_Of_Object (Syn_Inst : Synth_Instance_Acc; Expr : Node) + return Type_Acc; + + procedure Exec_Assignment_Prefix (Syn_Inst : Synth_Instance_Acc; + Pfx : Node; + Dest_Base : out Valtyp; + Dest_Typ : out Type_Acc; + Dest_Off : out Value_Offsets); + + function Exec_Name (Syn_Inst : Synth_Instance_Acc; Name : Node) + return Valtyp; + + -- Synthesize EXPR. The expression must be self-constrained. + -- If EN is not No_Net, the execution is controlled by EN. This is used + -- for assertions and checks. + function Exec_Expression + (Syn_Inst : Synth_Instance_Acc; Expr : Node) return Valtyp; + + -- Same as Synth_Expression, but the expression may be constrained by + -- EXPR_TYPE. + function Exec_Expression_With_Type (Syn_Inst : Synth_Instance_Acc; + Expr : Node; + Expr_Type : Type_Acc) return Valtyp; + + -- Use base type of EXPR to synthesize EXPR. Useful when the type of + -- EXPR is defined by itself or a range. + function Exec_Expression_With_Basetype (Syn_Inst : Synth_Instance_Acc; + Expr : Node) return Valtyp; + + -- Subtype conversion. + function Exec_Subtype_Conversion (Vt : Valtyp; + Dtype : Type_Acc; + Bounds : Boolean; + Loc : Node) + return Valtyp; + +end Elab.Vhdl_Expr; diff --git a/src/synth/elab-vhdl_files.adb b/src/synth/elab-vhdl_files.adb new file mode 100644 index 000000000..2e00265f6 --- /dev/null +++ b/src/synth/elab-vhdl_files.adb @@ -0,0 +1,418 @@ +-- Create declarations for 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 Files_Map; +with Name_Table; + +with Vhdl.Errors; use Vhdl.Errors; + +with Grt.Types; use Grt.Types; +with Grt.Files_Operations; use Grt.Files_Operations; +with Grt.Stdio; + +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; +with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; + +package body Elab.Vhdl_Files is + + -- Variables to store the search path. + Current_Unit : Node := Null_Node; + Current_Pfx_Len : Integer := -1; + Current_Pfx_Id : Name_Id := No_Name_Id; + + -- Representation of file name compatible with C (so NUL terminated). + subtype C_File_Name is String (1 .. 1025); + + procedure File_Error (Loc : Node; Status : Op_Status); + pragma No_Return (File_Error); + + procedure File_Error (Loc : Node; Status : Op_Status) is + begin + pragma Assert (Status /= Op_Ok); + Error_Msg_Elab (+Loc, "file operation failed"); + raise File_Execution_Error; + end File_Error; + + -- VAL represents a string, so an array of characters. + procedure Convert_String (Val : Valtyp; Res : out String) + is + Vtyp : constant Type_Acc := Val.Typ; + Vlen : constant Uns32 := Vtyp.Abounds.D (1).Len; + begin + pragma Assert (Vtyp.Kind = Type_Array); + pragma Assert (Vtyp.Arr_El.Kind = Type_Discrete); + pragma Assert (Vtyp.Arr_El.W in 7 .. 8); -- Could be 7 in vhdl87 + pragma Assert (Vtyp.Abounds.Ndim = 1); + pragma Assert (Vtyp.Abounds.D (1).Len = Res'Length); + + for I in 1 .. Vlen loop + Res (Res'First + Natural (I - 1)) := + Character'Val (Read_U8 (Val.Val.Mem + Size_Type (I - 1))); + end loop; + end Convert_String; + + -- Convert filename VAL to RES + LEN. + procedure Convert_File_Name (Val : Valtyp; + Res : out C_File_Name; + Len : out Natural; + Status : out Op_Status) + is + Name : constant Valtyp := Strip_Alias_Const (Val); + pragma Unreferenced (Val); + begin + Len := Natural (Name.Typ.Abounds.D (1).Len); + + if Len >= Res'Length - 1 then + Status := Op_Filename_Error; + return; + end if; + + Convert_String (Name, Res (1 .. Len)); + Res (Len + 1) := Grt.Types.NUL; + + Status := Op_Ok; + end Convert_File_Name; + + procedure Set_Design_Unit (Unit : Node) is + begin + Current_Unit := Unit; + Current_Pfx_Id := No_Name_Id; + end Set_Design_Unit; + + function Synth_Open (Name : Ghdl_C_String; Mode : Ghdl_C_String) + return Grt.Stdio.FILEs + is + use Grt.Stdio; + Res : FILEs; + begin + -- Try to open the file using the name given. + Res := fopen (To_Address (Name), To_Address (Mode)); + if Res /= NULL_Stream then + -- File found. + return Res; + end if; + + -- Return now if the search path is not used: + -- mode is not read, or + -- no search path given. + if Mode (1) /= 'r' then + return Res; + end if; + if Current_Unit = Null_Node then + return NULL_Stream; + end if; + + -- The search path is given by the current unit. Extract it from the + -- filename (and cache the result). + if Current_Pfx_Id = No_Name_Id then + declare + use Files_Map; + use Name_Table; + + Loc : Location_Type; + Sfe : Source_File_Entry; + Name_Len : Natural; + Name_Ptr : Thin_String_Ptr; + begin + Loc := Get_Location (Current_Unit); + Sfe := Location_To_File (Loc); + Current_Pfx_Id := Get_File_Name (Sfe); + Name_Len := Get_Name_Length (Current_Pfx_Id); + Name_Ptr := Get_Name_Ptr (Current_Pfx_Id); + Current_Pfx_Len := 0; + for I in reverse 1 .. Name_Len loop + if Name_Ptr (I) = '/' or else Name_Ptr (I) = '\' then + Current_Pfx_Len := I; + exit; + end if; + end loop; + end; + end if; + + -- No prefix. + if Current_Pfx_Len = 0 then + return NULL_Stream; + end if; + + -- Try with prefix + name. + declare + use Name_Table; + Name_Len : constant Natural := strlen (Name); + Pfx : constant Thin_String_Ptr := Get_Name_Ptr (Current_Pfx_Id); + Name2 : String (1 .. Name_Len + Current_Pfx_Len + 1); + begin + Name2 (1 .. Current_Pfx_Len) := Pfx (1 .. Current_Pfx_Len); + Name2 (Current_Pfx_Len + 1 .. Current_Pfx_Len + Name_Len) := + Name (1 .. Name_Len); + Name2 (Name2'Last) := NUL; + Res := fopen (Name2'Address, To_Address (Mode)); + end; + + return Res; + end Synth_Open; + + function Elaborate_File_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index + is + File_Type : constant Node := Get_Type (Decl); + External_Name : constant Node := Get_File_Logical_Name (Decl); + Open_Kind : constant Node := Get_File_Open_Kind (Decl); + File_Name : Valtyp; + C_Name : C_File_Name; + C_Name_Len : Natural; + Mode : Valtyp; + F : File_Index; + File_Mode : Ghdl_I32; + Status : Op_Status; + begin + -- Use our own handler to open a file. + -- We need to do this assignment only once, but it is simpler to do it + -- here. + Open_Handler := Synth_Open'Access; + + if Get_Text_File_Flag (File_Type) then + F := Ghdl_Text_File_Elaborate; + else + declare + File_Typ : Type_Acc; + Cstr : Ghdl_C_String; + begin + File_Typ := Get_Subtype_Object (Syn_Inst, File_Type); + if File_Typ.File_Signature = null then + Cstr := null; + else + Cstr := To_Ghdl_C_String (File_Typ.File_Signature.all'Address); + end if; + F := Ghdl_File_Elaborate (Cstr); + end; + end if; + + -- LRM93 4.3.1.4 + -- If file open information is not included in a given file declaration, + -- then the file declared by the declaration is not opened when the file + -- declaration is elaborated. + if External_Name = Null_Node then + return F; + end if; + + File_Name := Exec_Expression_With_Basetype (Syn_Inst, External_Name); + + if Open_Kind /= Null_Node then + Mode := Exec_Expression (Syn_Inst, Open_Kind); + File_Mode := Ghdl_I32 (Read_Discrete (Mode)); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + File_Mode := Read_Mode; + when Iir_Out_Mode => + File_Mode := Write_Mode; + when others => + raise Internal_Error; + end case; + end if; + + Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); + if Status = Op_Ok then + if Get_Text_File_Flag (File_Type) then + Ghdl_Text_File_Open + (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); + else + Ghdl_File_Open + (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); + end if; + end if; + + if Status /= Op_Ok then + if Status = Op_Name_Error then + Error_Msg_Elab + (+Decl, "cannot open file: " & C_Name (1 .. C_Name_Len)); + Set_Error (Syn_Inst); + else + File_Error (Decl, Status); + end if; + end if; + + return F; + end Elaborate_File_Declaration; + + function Endfile (F : File_Index; Loc : Node) return Boolean + is + Status : Op_Status; + begin + Ghdl_File_Endfile (F, Status); + + if Status = Op_Ok then + return False; + elsif Status = Op_End_Of_File then + return True; + else + File_Error (Loc, Status); + end if; + end Endfile; + + -- Declaration + -- procedure FILE_OPEN (file F : FT; + -- External_Name : String; + -- Open_Kind : File_Open_Kind); + procedure Synth_File_Open + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) + is + Inters : constant Node := Get_Interface_Declaration_Chain (Imp); + F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; + Param2 : constant Node := Get_Chain (Inters); + File_Name : constant Valtyp := Get_Value (Syn_Inst, Param2); + Param3 : constant Node := Get_Chain (Param2); + Open_Kind : constant Valtyp := Get_Value (Syn_Inst, Param3); + C_Name : C_File_Name; + C_Name_Len : Natural; + File_Mode : Ghdl_I32; + Status : Op_Status; + begin + Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); + if Status = Op_Ok then + File_Mode := Ghdl_I32 (Read_Discrete (Open_Kind)); + if Get_Text_File_Flag (Get_Type (Inters)) then + Ghdl_Text_File_Open + (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); + else + Ghdl_File_Open + (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); + end if; + end if; + + if Status /= Op_Ok then + if Status = Op_Name_Error then + Error_Msg_Elab + (+Loc, "cannot open file: " & C_Name (1 .. C_Name_Len)); + raise File_Execution_Error; + else + File_Error (Loc, Status); + end if; + end if; + end Synth_File_Open; + + -- Declaration + -- procedure FILE_CLOSE (file F : FT); + procedure Synth_File_Close + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) + is + Inters : constant Node := Get_Interface_Declaration_Chain (Imp); + F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; + Status : Op_Status; + begin + if Get_Text_File_Flag (Get_Type (Inters)) then + Ghdl_Text_File_Close (F, Status); + else + Ghdl_File_Close (F, Status); + end if; + + if Status /= Op_Ok then + File_Error (Loc, Status); + end if; + end Synth_File_Close; + + -- Declaration: + -- procedure untruncated_text_read --!V87 + -- (file f : text; str : out string; len : out natural); --!V87 + procedure Synth_Untruncated_Text_Read (Syn_Inst : Synth_Instance_Acc; + Imp : Node; + Loc : Node) + is + Inters : constant Node := Get_Interface_Declaration_Chain (Imp); + File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; + Param2 : constant Node := Get_Chain (Inters); + Str : constant Valtyp := Get_Value (Syn_Inst, Param2); + Param3 : constant Node := Get_Chain (Param2); + Param_Len : constant Valtyp := Get_Value (Syn_Inst, Param3); + Buf : String (1 .. Natural (Str.Typ.Abounds.D (1).Len)); + Len : Std_Integer; + Status : Op_Status; + begin + Len := Std_Integer (Buf'Last); + Ghdl_Untruncated_Text_Read + (File, To_Ghdl_C_String (Buf'Address), Len, Status); + if Status /= Op_Ok then + File_Error (Loc, Status); + end if; + + for I in 1 .. Natural (Len) loop + Write_U8 (Str.Val.Mem + Size_Type (I - 1), Character'Pos (Buf (I))); + end loop; + + Write_Discrete (Param_Len, Int64 (Len)); + end Synth_Untruncated_Text_Read; + + procedure File_Read_Value (File : File_Index; Val : Memtyp; Loc : Node) + is + Status : Op_Status; + begin + case Val.Typ.Kind is + when Type_Discrete + | Type_Bit + | Type_Logic + | Type_Float => + Ghdl_Read_Scalar (File, Ghdl_Ptr (Val.Mem.all'Address), + Ghdl_Index_Type (Val.Typ.Sz), Status); + if Status /= Op_Ok then + File_Error (Loc, Status); + end if; + when Type_Vector + | Type_Array => + declare + El_Typ : constant Type_Acc := Get_Array_Element (Val.Typ); + Off : Size_Type; + begin + Off := 0; + for I in 1 .. Get_Array_Flat_Length (Val.Typ) loop + File_Read_Value (File, (El_Typ, Val.Mem + Off), Loc); + Off := Off + El_Typ.Sz; + end loop; + end; + when Type_Record => + for I in Val.Typ.Rec.E'Range loop + File_Read_Value + (File, + (Val.Typ.Rec.E (I).Typ, Val.Mem + Val.Typ.Rec.E (I).Moff), + Loc); + end loop; + when Type_Unbounded_Record + | Type_Unbounded_Array + | Type_Unbounded_Vector + | Type_Protected + | Type_Slice + | Type_File + | Type_Access => + raise Internal_Error; + end case; + end File_Read_Value; + + procedure Synth_File_Read + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) + is + Inters : constant Node := Get_Interface_Declaration_Chain (Imp); + File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; + Param2 : constant Node := Get_Chain (Inters); + Value : constant Valtyp := Get_Value (Syn_Inst, Param2); + begin + File_Read_Value (File, (Value.Typ, Value.Val.Mem), Loc); + end Synth_File_Read; + +end Elab.Vhdl_Files; diff --git a/src/synth/elab-vhdl_files.ads b/src/synth/elab-vhdl_files.ads new file mode 100644 index 000000000..7987e0ccf --- /dev/null +++ b/src/synth/elab-vhdl_files.ads @@ -0,0 +1,47 @@ +-- Create declarations for 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 Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + +package Elab.Vhdl_Files is + -- Raised in case of un-recoverable error. + File_Execution_Error : exception; + + -- Set the current design unit, so that its path can be used to search + -- files. + procedure Set_Design_Unit (Unit : Node); + + function Elaborate_File_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index; + + function Endfile (F : File_Index; Loc : Node) return Boolean; + + procedure Synth_File_Open + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); + procedure Synth_File_Close + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); + + procedure Synth_Untruncated_Text_Read + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); + + procedure Synth_File_Read + (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); +end Elab.Vhdl_Files; diff --git a/src/synth/elab-vhdl_heap.adb b/src/synth/elab-vhdl_heap.adb new file mode 100644 index 000000000..a6027bfef --- /dev/null +++ b/src/synth/elab-vhdl_heap.adb @@ -0,0 +1,93 @@ +-- Heap for 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 Tables; + +with Elab.Memtype; use Elab.Memtype; + +package body Elab.Vhdl_Heap is + + package Heap_Table is new Tables + (Table_Component_Type => Valtyp, + Table_Index_Type => Heap_Index, + Table_Low_Bound => 1, + Table_Initial => 16); + + function Alloc_Mem (Sz : Size_Type) return Memory_Ptr; + pragma Import (C, Alloc_Mem, "malloc"); + + function Allocate_Memory (T : Type_Acc) return Value_Acc + is + M : Memory_Ptr; + begin + M := Alloc_Mem (T.Sz); + return new Value_Type'(Kind => Value_Memory, Mem => M); + end Allocate_Memory; + + function Allocate_By_Type (T : Type_Acc) return Value_Acc + is + Res : Value_Acc; + begin + Res := Allocate_Memory (T); + Write_Value_Default (Res.Mem, T); + return Res; + end Allocate_By_Type; + + function Allocate_By_Type (T : Type_Acc) return Heap_Index is + begin + -- FIXME: allocate type. + Heap_Table.Append ((T, Allocate_By_Type (T))); + return Heap_Table.Last; + end Allocate_By_Type; + + function Allocate_By_Value (V : Valtyp) return Value_Acc + is + Res : Value_Acc; + begin + Res := Allocate_Memory (V.Typ); + Write_Value (Res.Mem, V); + return Res; + end Allocate_By_Value; + + function Allocate_By_Value (V : Valtyp) return Heap_Index is + begin + Heap_Table.Append ((V.Typ, Allocate_By_Value (V))); + return Heap_Table.Last; + end Allocate_By_Value; + + function Synth_Dereference (Idx : Heap_Index) return Valtyp is + begin + return Heap_Table.Table (Idx); + end Synth_Dereference; + + procedure Free (Obj : in out Valtyp) is + begin + -- TODO + Obj := No_Valtyp; + end Free; + + procedure Synth_Deallocate (Idx : Heap_Index) is + begin + if Heap_Table.Table (Idx) = No_Valtyp then + return; + end if; + Free (Heap_Table.Table (Idx)); + end Synth_Deallocate; + +end Elab.Vhdl_Heap; diff --git a/src/synth/elab-vhdl_heap.ads b/src/synth/elab-vhdl_heap.ads new file mode 100644 index 000000000..e6c9db777 --- /dev/null +++ b/src/synth/elab-vhdl_heap.ads @@ -0,0 +1,30 @@ +-- Heap for 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 Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + +package Elab.Vhdl_Heap is + -- Allocate a value. + function Allocate_By_Type (T : Type_Acc) return Heap_Index; + function Allocate_By_Value (V : Valtyp) return Heap_Index; + + function Synth_Dereference (Idx : Heap_Index) return Valtyp; + + procedure Synth_Deallocate (Idx : Heap_Index); +end Elab.Vhdl_Heap; diff --git a/src/synth/elab-vhdl_insts.adb b/src/synth/elab-vhdl_insts.adb new file mode 100644 index 000000000..e5fc5e97b --- /dev/null +++ b/src/synth/elab-vhdl_insts.adb @@ -0,0 +1,673 @@ +-- Design elaboration +-- Copyright (C) 2021 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 Libraries; + +with Vhdl.Utils; use Vhdl.Utils; +with Vhdl.Std_Package; +with Vhdl.Annotations; +with Vhdl.Configuration; use Vhdl.Configuration; +with Vhdl.Errors; use Vhdl.Errors; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Decls; use Elab.Vhdl_Decls; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Vhdl_Stmts; use Elab.Vhdl_Stmts; +with Elab.Vhdl_Files; +with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; +with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; + +package body Elab.Vhdl_Insts is + procedure Elab_Convertible_Declarations (Syn_Inst : Synth_Instance_Acc) + is + use Vhdl.Std_Package; + begin + Create_Subtype_Object + (Syn_Inst, Convertible_Integer_Type_Definition, + Get_Subtype_Object (Syn_Inst, Universal_Integer_Type_Definition)); + Create_Subtype_Object + (Syn_Inst, Convertible_Real_Type_Definition, + Get_Subtype_Object (Syn_Inst, Universal_Real_Type_Definition)); + end Elab_Convertible_Declarations; + + procedure Elab_Generics_Association (Sub_Inst : Synth_Instance_Acc; + Syn_Inst : Synth_Instance_Acc; + Inter_Chain : Node; + Assoc_Chain : Node) + is + Inter : Node; + Inter_Type : Type_Acc; + Assoc : Node; + Assoc_Inter : Node; + Actual : Node; + Val : Valtyp; + begin + Assoc := Assoc_Chain; + Assoc_Inter := Inter_Chain; + while Is_Valid (Assoc) loop + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is + when Iir_Kind_Interface_Constant_Declaration => + Elab_Declaration_Type (Sub_Inst, Inter); + Inter_Type := Get_Subtype_Object (Sub_Inst, Get_Type (Inter)); + + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Inter); + Val := Exec_Expression_With_Type + (Sub_Inst, Actual, Inter_Type); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + Val := Exec_Expression_With_Type + (Syn_Inst, Actual, Inter_Type); + when others => + raise Internal_Error; + end case; + + Val := Exec_Subtype_Conversion (Val, Inter_Type, True, Assoc); + + if Val = No_Valtyp then + Set_Error (Sub_Inst); + elsif not Is_Static (Val.Val) then + Error_Msg_Elab + (+Assoc, "value of generic %i must be static", +Inter); + Val := No_Valtyp; + Set_Error (Sub_Inst); + end if; + + Create_Object (Sub_Inst, Inter, Val); + + when Iir_Kind_Interface_Package_Declaration => + declare + Actual : constant Iir := + Strip_Denoting_Name (Get_Actual (Assoc)); + Pkg_Inst : Synth_Instance_Acc; + begin + Pkg_Inst := Get_Package_Object (Sub_Inst, Actual); + Create_Package_Interface (Sub_Inst, Inter, Pkg_Inst); + end; + + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Quantity_Declaration + | Iir_Kind_Interface_Terminal_Declaration => + raise Internal_Error; + + when Iir_Kinds_Interface_Subprogram_Declaration + | Iir_Kind_Interface_Type_Declaration => + raise Internal_Error; + end case; + + Next_Association_Interface (Assoc, Assoc_Inter); + end loop; + end Elab_Generics_Association; + + procedure Elab_Package_Declaration + (Parent_Inst : Synth_Instance_Acc; Pkg : Node) + is + Syn_Inst : Synth_Instance_Acc; + begin + if Is_Uninstantiated_Package (Pkg) then + -- Nothing to do (yet) for uninstantiated packages. + return; + end if; + + Syn_Inst := Create_Package_Instance (Parent_Inst, Pkg); + + Elab_Declarations (Syn_Inst, Get_Declaration_Chain (Pkg)); + if Pkg = Vhdl.Std_Package.Standard_Package then + Elab_Convertible_Declarations (Syn_Inst); + end if; + end Elab_Package_Declaration; + + procedure Elab_Package_Body + (Parent_Inst : Synth_Instance_Acc; Pkg : Node; Bod : Node) + is + Pkg_Inst : Synth_Instance_Acc; + begin + if Is_Uninstantiated_Package (Pkg) then + -- Nothing to do (yet) for uninstantiated packages. + return; + end if; + + Pkg_Inst := Get_Package_Object (Parent_Inst, Pkg); + + Elab_Declarations (Pkg_Inst, Get_Declaration_Chain (Bod)); + end Elab_Package_Body; + + procedure Elab_Package_Instantiation + (Parent_Inst : Synth_Instance_Acc; Pkg : Node) + is + Bod : constant Node := Get_Instance_Package_Body (Pkg); + Sub_Inst : Synth_Instance_Acc; + begin + Sub_Inst := Create_Package_Instance (Parent_Inst, Pkg); + + Elab_Generics_Association + (Sub_Inst, Parent_Inst, + Get_Generic_Chain (Pkg), Get_Generic_Map_Aspect_Chain (Pkg)); + + Elab_Declarations (Sub_Inst, Get_Declaration_Chain (Pkg)); + + if Bod /= Null_Node then + -- Macro expanded package instantiation. + raise Internal_Error; + else + -- Shared body + declare + Uninst : constant Node := Get_Uninstantiated_Package_Decl (Pkg); + Uninst_Bod : constant Node := Get_Package_Body (Uninst); + begin + Set_Uninstantiated_Scope (Sub_Inst, Uninst); + -- Synth declarations of (optional) body. + if Uninst_Bod /= Null_Node then + Elab_Declarations + (Sub_Inst, Get_Declaration_Chain (Uninst_Bod)); + end if; + end; + end if; + end Elab_Package_Instantiation; + + procedure Elab_Dependencies (Parent_Inst : Synth_Instance_Acc; Unit : Node) + is + Dep_List : constant Node_List := Get_Dependence_List (Unit); + Dep_It : List_Iterator; + Dep : Node; + Dep_Unit : Node; + begin + Dep_It := List_Iterate (Dep_List); + while Is_Valid (Dep_It) loop + Dep := Get_Element (Dep_It); + if Get_Kind (Dep) = Iir_Kind_Design_Unit + and then not Get_Elab_Flag (Dep) + then + Set_Elab_Flag (Dep, True); + Elab_Dependencies (Parent_Inst, Dep); + Dep_Unit := Get_Library_Unit (Dep); + case Iir_Kinds_Library_Unit (Get_Kind (Dep_Unit)) is + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Context_Declaration => + null; + when Iir_Kind_Package_Declaration => + declare + Bod : constant Node := Get_Package_Body (Dep_Unit); + Bod_Unit : Node; + begin + Elab_Package_Declaration (Parent_Inst, Dep_Unit); + -- Do not try to elaborate math_real body: there are + -- functions with loop. Currently, try create signals, + -- which is not possible during package elaboration. + if Bod /= Null_Node then + Bod_Unit := Get_Design_Unit (Bod); + Elab_Dependencies (Parent_Inst, Bod_Unit); + Elab_Package_Body (Parent_Inst, Dep_Unit, Bod); + end if; + end; + when Iir_Kind_Package_Instantiation_Declaration => + Elab_Package_Instantiation (Parent_Inst, Dep_Unit); + when Iir_Kind_Package_Body => + null; + when Iir_Kind_Architecture_Body => + null; + when Iir_Kinds_Verification_Unit => + null; + end case; + end if; + Next (Dep_It); + end loop; + end Elab_Dependencies; + + procedure Apply_Block_Configuration (Cfg : Node; Blk : Node) + is + Item : Node; + begin + -- Be sure CFG applies to BLK. + pragma Assert (Get_Block_From_Block_Specification + (Get_Block_Specification (Cfg)) = Blk); + + -- Clear_Instantiation_Configuration (Blk); + + Item := Get_Configuration_Item_Chain (Cfg); + while Item /= Null_Node loop + case Get_Kind (Item) is + when Iir_Kind_Component_Configuration => + declare + List : constant Iir_Flist := + Get_Instantiation_List (Item); + El : Node; + Inst : Node; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Inst := Get_Named_Entity (El); + pragma Assert + (Get_Kind (Inst) + = Iir_Kind_Component_Instantiation_Statement); + pragma Assert + (Get_Component_Configuration (Inst) = Null_Node); + Set_Component_Configuration (Inst, Item); + end loop; + end; + when Iir_Kind_Block_Configuration => + declare + Sub_Blk : constant Node := Get_Block_From_Block_Specification + (Get_Block_Specification (Item)); + begin + case Get_Kind (Sub_Blk) is + when Iir_Kind_Generate_Statement_Body => + -- Linked chain. + Set_Prev_Block_Configuration + (Item, Get_Generate_Block_Configuration (Sub_Blk)); + Set_Generate_Block_Configuration (Sub_Blk, Item); + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (Sub_Blk, Item); + when others => + Vhdl.Errors.Error_Kind + ("apply_block_configuration(blk)", Sub_Blk); + end case; + end; + when others => + Vhdl.Errors.Error_Kind ("apply_block_configuration", Item); + end case; + Item := Get_Chain (Item); + end loop; + end Apply_Block_Configuration; + + function Elab_Port_Association_Type (Sub_Inst : Synth_Instance_Acc; + Syn_Inst : Synth_Instance_Acc; + Inter : Node; + Assoc : Node) return Type_Acc is + begin + if not Is_Fully_Constrained_Type (Get_Type (Inter)) then + -- TODO + -- Find the association for this interface + -- * if individual assoc: get type + -- * if whole assoc: get type from object. + if Assoc = Null_Node then + raise Internal_Error; + end if; + case Get_Kind (Assoc) is + when Iir_Kinds_Association_Element_By_Actual => + return Exec_Type_Of_Object (Syn_Inst, Get_Actual (Assoc)); + when others => + raise Internal_Error; + end case; + else + Elab_Declaration_Type (Sub_Inst, Inter); + return Get_Subtype_Object (Sub_Inst, Get_Type (Inter)); + end if; + end Elab_Port_Association_Type; + + procedure Elab_Ports_Association_Type (Sub_Inst : Synth_Instance_Acc; + Syn_Inst : Synth_Instance_Acc; + Inter_Chain : Node; + Assoc_Chain : Node) + is + Inter : Node; + Assoc : Node; + Assoc_Inter : Node; + Inter_Typ : Type_Acc; + begin + Assoc := Assoc_Chain; + Assoc_Inter := Inter_Chain; + while Is_Valid (Assoc) loop + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + if Get_Whole_Association_Flag (Assoc) then + Inter_Typ := Elab_Port_Association_Type + (Sub_Inst, Syn_Inst, Inter, Assoc); + Create_Signal (Sub_Inst, Inter, Inter_Typ, null); + end if; + Next_Association_Interface (Assoc, Assoc_Inter); + end loop; + end Elab_Ports_Association_Type; + + procedure Elab_Verification_Unit + (Syn_Inst : Synth_Instance_Acc; Unit : Node) + is + Unit_Inst : Synth_Instance_Acc; + Item : Node; + Last_Type : Node; + begin + Unit_Inst := Make_Elab_Instance (Syn_Inst, Unit, Config => Null_Node); + Add_Extra_Instance (Syn_Inst, Unit_Inst); + + Apply_Block_Configuration + (Get_Verification_Block_Configuration (Unit), Unit); + + Last_Type := Null_Node; + Item := Get_Vunit_Item_Chain (Unit); + while Item /= Null_Node loop + case Get_Kind (Item) is + when Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Directive + | Iir_Kind_Psl_Assume_Directive + | Iir_Kind_Psl_Cover_Directive + | Iir_Kind_Psl_Restrict_Directive => + null; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification => + Elab_Declaration (Unit_Inst, Item, Last_Type); + when Iir_Kinds_Concurrent_Signal_Assignment + | Iir_Kinds_Process_Statement + | Iir_Kinds_Generate_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Component_Instantiation_Statement => + Elab_Concurrent_Statement (Unit_Inst, Item); + when others => + Error_Kind ("elab_vunit_declaration", Item); + end case; + Item := Get_Chain (Item); + end loop; + end Elab_Verification_Unit; + + procedure Elab_Verification_Units + (Syn_Inst : Synth_Instance_Acc; Parent : Node) + is + Unit : Node; + begin + Unit := Get_Bound_Vunit_Chain (Parent); + while Unit /= Null_Node loop + Elab_Verification_Unit (Syn_Inst, Unit); + Unit := Get_Bound_Vunit_Chain (Unit); + end loop; + end Elab_Verification_Units; + + procedure Elab_Instance_Body (Syn_Inst : Synth_Instance_Acc; + Entity : Node; + Arch : Node; + Config : Node) is + begin + Apply_Block_Configuration (Config, Arch); + + Elab_Declarations (Syn_Inst, Get_Declaration_Chain (Entity)); + Elab_Concurrent_Statements + (Syn_Inst, Get_Concurrent_Statement_Chain (Entity)); + + Elab_Verification_Units (Syn_Inst, Entity); + + Elab_Declarations (Syn_Inst, Get_Declaration_Chain (Arch)); + Elab_Concurrent_Statements + (Syn_Inst, Get_Concurrent_Statement_Chain (Arch)); + + Elab_Verification_Units (Syn_Inst, Arch); + end Elab_Instance_Body; + + procedure Elab_Direct_Instantiation_Statement + (Syn_Inst : Synth_Instance_Acc; + Stmt : Node; + Entity : Node; + Arch : Node; + Config : Node) + is + Sub_Inst : Synth_Instance_Acc; + begin + -- Elaborate generic + map aspect + Sub_Inst := Make_Elab_Instance (Syn_Inst, Arch, Config); + + Create_Sub_Instance (Syn_Inst, Stmt, Sub_Inst); + + Elab_Dependencies (Root_Instance, Get_Design_Unit (Entity)); + Elab_Dependencies (Root_Instance, Get_Design_Unit (Arch)); + + + Elab_Generics_Association (Sub_Inst, Syn_Inst, + Get_Generic_Chain (Entity), + Get_Generic_Map_Aspect_Chain (Stmt)); + + -- Elaborate port types. + Elab_Ports_Association_Type (Sub_Inst, Syn_Inst, + Get_Port_Chain (Entity), + Get_Port_Map_Aspect_Chain (Stmt)); + + if Is_Error (Sub_Inst) then + -- TODO: Free it? + return; + end if; + + -- Recurse. + Elab_Instance_Body (Sub_Inst, Entity, Arch, Config); + end Elab_Direct_Instantiation_Statement; + + procedure Elab_Component_Instantiation_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) + is + Component : constant Node := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + Config : constant Node := Get_Component_Configuration (Stmt); + Bind : constant Node := Get_Binding_Indication (Config); + Aspect : Iir; + Comp_Inst : Synth_Instance_Acc; + + Ent : Node; + Arch : Node; + Sub_Config : Node; + Sub_Inst : Synth_Instance_Acc; + begin + -- Create the sub-instance for the component + -- Elaborate generic + map aspect + Comp_Inst := Make_Elab_Instance (Syn_Inst, Component, Config); + Create_Sub_Instance (Syn_Inst, Stmt, Comp_Inst); + + Elab_Generics_Association (Comp_Inst, Syn_Inst, + Get_Generic_Chain (Component), + Get_Generic_Map_Aspect_Chain (Stmt)); + + -- Create objects for the inputs and the outputs of the component, + -- assign inputs (that's nets) and create wires for outputs. + declare + Assoc : Node; + Assoc_Inter : Node; + Inter : Node; + Inter_Typ : Type_Acc; + begin + Assoc := Get_Port_Map_Aspect_Chain (Stmt); + Assoc_Inter := Get_Port_Chain (Component); + while Is_Valid (Assoc) loop + if Get_Whole_Association_Flag (Assoc) then + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + + Inter_Typ := Elab_Port_Association_Type + (Comp_Inst, Syn_Inst, Inter, Assoc); + + Create_Signal (Comp_Inst, Assoc_Inter, Inter_Typ, null); + end if; + Next_Association_Interface (Assoc, Assoc_Inter); + end loop; + end; + + Set_Component_Configuration (Stmt, Null_Node); + + if Bind = Null_Iir then + -- No association. + return; + end if; + + Aspect := Get_Entity_Aspect (Bind); + + -- Extract entity/architecture instantiated by the component. + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Ent := Get_Entity (Aspect); + Arch := Get_Architecture (Aspect); + when others => + Vhdl.Errors.Error_Kind + ("Elab_Component_Instantiation_Statement(2)", Aspect); + end case; + + if Get_Kind (Ent) = Iir_Kind_Foreign_Module then + -- TODO. + raise Internal_Error; + end if; + + if Arch = Null_Node then + Arch := Libraries.Get_Latest_Architecture (Ent); + else + Arch := Get_Named_Entity (Arch); + end if; + Sub_Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + Sub_Config := Get_Block_Configuration (Sub_Config); + + Elab_Dependencies (Root_Instance, Get_Design_Unit (Ent)); + Elab_Dependencies (Root_Instance, Get_Design_Unit (Arch)); + + -- Elaborate generic + map aspect for the entity instance. + Sub_Inst := Make_Elab_Instance (Comp_Inst, Arch, Sub_Config); + Create_Component_Instance (Comp_Inst, Sub_Inst); + + Elab_Generics_Association (Sub_Inst, Comp_Inst, + Get_Generic_Chain (Ent), + Get_Generic_Map_Aspect_Chain (Bind)); + + Elab_Ports_Association_Type (Sub_Inst, Comp_Inst, + Get_Port_Chain (Ent), + Get_Port_Map_Aspect_Chain (Bind)); + + -- Recurse. + -- TODO: factorize with direct instantiation + Elab_Instance_Body (Sub_Inst, Ent, Arch, Sub_Config); + end Elab_Component_Instantiation_Statement; + + procedure Elab_Design_Instantiation_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) + is + Aspect : constant Iir := Get_Instantiated_Unit (Stmt); + Arch : Node; + Ent : Node; + Config : Node; + begin + -- Load configured entity + architecture + case Iir_Kinds_Entity_Aspect (Get_Kind (Aspect)) is + when Iir_Kind_Entity_Aspect_Entity => + Arch := Get_Architecture (Aspect); + if Arch = Null_Node then + Arch := Libraries.Get_Latest_Architecture (Get_Entity (Aspect)); + else + Arch := Strip_Denoting_Name (Arch); + end if; + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Arch := Get_Block_Specification (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + end case; + Config := Get_Block_Configuration (Config); + Ent := Get_Entity (Arch); + + Elab_Direct_Instantiation_Statement + (Syn_Inst, Stmt, Ent, Arch, Config); + end Elab_Design_Instantiation_Statement; + + function Elab_Top_Unit (Config : Node) return Synth_Instance_Acc + is + Arch : Node; + Entity : Node; + Inter : Node; + Top_Inst : Synth_Instance_Acc; + begin + Arch := Get_Named_Entity + (Get_Block_Specification (Get_Block_Configuration (Config))); + Entity := Get_Entity (Arch); + + -- Annotate units. + Vhdl.Annotations.Flag_Synthesis := True; + Vhdl.Annotations.Initialize_Annotate; + Vhdl.Annotations.Annotate (Vhdl.Std_Package.Std_Standard_Unit); + for I in Design_Units.First .. Design_Units.Last loop + Vhdl.Annotations.Annotate (Design_Units.Table (I)); + end loop; + + Elab.Vhdl_Objtypes.Init; + + -- Start elaboration. + Make_Root_Instance; + + Top_Inst := Make_Elab_Instance (Root_Instance, Arch, Null_Node); + + -- Save the current architecture, so that files can be open using a + -- path relative to the architecture filename. + Elab.Vhdl_Files.Set_Design_Unit (Arch); + + Elab_Dependencies (Root_Instance, Get_Design_Unit (Entity)); + Elab_Dependencies (Root_Instance, Get_Design_Unit (Arch)); + + -- Compute generics. + Inter := Get_Generic_Chain (Entity); + while Is_Valid (Inter) loop + Elab_Declaration_Type (Top_Inst, Inter); + declare + Val : Valtyp; + Inter_Typ : Type_Acc; + begin + Inter_Typ := Get_Subtype_Object (Top_Inst, Get_Type (Inter)); + Val := Exec_Expression_With_Type + (Top_Inst, Get_Default_Value (Inter), Inter_Typ); + pragma Assert (Is_Static (Val.Val)); + Create_Object (Top_Inst, Inter, Val); + end; + Inter := Get_Chain (Inter); + end loop; + + -- Elaborate port types. + -- FIXME: what about unconstrained ports ? Get the type from the + -- association. + Inter := Get_Port_Chain (Entity); + while Is_Valid (Inter) loop + if not Is_Fully_Constrained_Type (Get_Type (Inter)) then + -- TODO + raise Internal_Error; + end if; + declare + Inter_Typ : Type_Acc; + begin + Elab_Declaration_Type (Top_Inst, Inter); + Inter_Typ := Get_Subtype_Object (Top_Inst, Get_Type (Inter)); + Create_Signal (Top_Inst, Inter, Inter_Typ, null); + end; + Inter := Get_Chain (Inter); + end loop; + + Elab_Instance_Body + (Top_Inst, Entity, Arch, Get_Block_Configuration (Config)); + + -- Clear elab_flag + for I in Design_Units.First .. Design_Units.Last loop + Set_Elab_Flag (Design_Units.Table (I), False); + end loop; + + return Top_Inst; + end Elab_Top_Unit; + +end Elab.Vhdl_Insts; diff --git a/src/synth/elab-vhdl_insts.ads b/src/synth/elab-vhdl_insts.ads new file mode 100644 index 000000000..3c34fa4ed --- /dev/null +++ b/src/synth/elab-vhdl_insts.ads @@ -0,0 +1,36 @@ +-- Design elaboration +-- Copyright (C) 2021 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 Elab.Vhdl_Context; use Elab.Vhdl_Context; + +package Elab.Vhdl_Insts is + function Elab_Top_Unit (Config : Node) return Synth_Instance_Acc; + + procedure Elab_Component_Instantiation_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node); + procedure Elab_Design_Instantiation_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node); + + -- Apply block configuration CFG to BLK. + -- Must be done before synthesis of BLK. + -- The synthesis of BLK will clear all configuration of it. + procedure Apply_Block_Configuration (Cfg : Node; Blk : Node); + +end Elab.Vhdl_Insts; diff --git a/src/synth/elab-vhdl_objtypes.adb b/src/synth/elab-vhdl_objtypes.adb new file mode 100644 index 000000000..da223b4a2 --- /dev/null +++ b/src/synth/elab-vhdl_objtypes.adb @@ -0,0 +1,784 @@ +-- Values in 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 Ada.Unchecked_Conversion; +with System; use System; + +with Mutils; use Mutils; + +package body Elab.Vhdl_Objtypes is + function To_Bound_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Bound_Array_Acc); + + function To_Rec_El_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Rec_El_Array_Acc); + + function To_Type_Acc is new Ada.Unchecked_Conversion + (System.Address, Type_Acc); + + function "+" (L, R : Value_Offsets) return Value_Offsets is + begin + return (L.Net_Off + R.Net_Off, L.Mem_Off + R.Mem_Off); + end "+"; + + function Is_Bounded_Type (Typ : Type_Acc) return Boolean is + begin + case Typ.Kind is + when Type_Bit + | Type_Logic + | Type_Discrete + | Type_Float + | Type_Vector + | Type_Slice + | Type_Array + | Type_Record + | Type_Access + | Type_File => + return True; + when Type_Unbounded_Array + | Type_Unbounded_Vector + | Type_Unbounded_Record + | Type_Protected => + return False; + end case; + end Is_Bounded_Type; + + function Are_Types_Equal (L, R : Type_Acc) return Boolean is + begin + if L.Kind /= R.Kind + or else L.W /= R.W + then + return False; + end if; + if L = R then + return True; + end if; + + case L.Kind is + when Type_Bit + | Type_Logic => + return True; + when Type_Discrete => + return L.Drange = R.Drange; + when Type_Float => + return L.Frange = R.Frange; + when Type_Vector => + return L.Vbound = R.Vbound + and then Are_Types_Equal (L.Vec_El, R.Vec_El); + when Type_Unbounded_Vector => + return Are_Types_Equal (L.Uvec_El, R.Uvec_El); + when Type_Slice => + return Are_Types_Equal (L.Slice_El, R.Slice_El); + when Type_Array => + if L.Abounds.Ndim /= R.Abounds.Ndim then + return False; + end if; + for I in L.Abounds.D'Range loop + if L.Abounds.D (I) /= R.Abounds.D (I) then + return False; + end if; + end loop; + return Are_Types_Equal (L.Arr_El, R.Arr_El); + when Type_Unbounded_Array => + return L.Uarr_Ndim = R.Uarr_Ndim + and then Are_Types_Equal (L.Uarr_El, R.Uarr_El); + when Type_Record + | Type_Unbounded_Record => + if L.Rec.Len /= R.Rec.Len then + return False; + end if; + for I in L.Rec.E'Range loop + if not Are_Types_Equal (L.Rec.E (I).Typ, R.Rec.E (I).Typ) then + return False; + end if; + end loop; + return True; + when Type_Access => + return Are_Types_Equal (L.Acc_Acc, R.Acc_Acc); + when Type_File => + return Are_Types_Equal (L.File_Typ, R.File_Typ); + when Type_Protected => + return False; + end case; + end Are_Types_Equal; + + function Discrete_Range_Width (Rng : Discrete_Range_Type) return Uns32 + is + Lo, Hi : Int64; + W : Uns32; + begin + case Rng.Dir is + when Dir_To => + Lo := Rng.Left; + Hi := Rng.Right; + when Dir_Downto => + Lo := Rng.Right; + Hi := Rng.Left; + end case; + if Lo > Hi then + -- Null range. + W := 0; + elsif Lo >= 0 then + -- Positive. + W := Uns32 (Clog2 (Uns64 (Hi) + 1)); + elsif Lo = Int64'First then + -- Handle possible overflow. + W := 64; + elsif Hi < 0 then + -- Negative only. + W := Uns32 (Clog2 (Uns64 (-Lo))) + 1; + else + declare + Wl : constant Uns32 := Uns32 (Clog2 (Uns64 (-Lo))); + Wh : constant Uns32 := Uns32 (Clog2 (Uns64 (Hi) + 1)); + begin + W := Uns32'Max (Wl, Wh) + 1; + end; + end if; + return W; + end Discrete_Range_Width; + + function In_Bounds (Bnd : Bound_Type; V : Int32) return Boolean is + begin + case Bnd.Dir is + when Dir_To => + return V >= Bnd.Left and then V <= Bnd.Right; + when Dir_Downto => + return V <= Bnd.Left and then V >= Bnd.Right; + end case; + end In_Bounds; + + function In_Range (Rng : Discrete_Range_Type; V : Int64) return Boolean is + begin + case Rng.Dir is + when Dir_To => + return V >= Rng.Left and then V <= Rng.Right; + when Dir_Downto => + return V <= Rng.Left and then V >= Rng.Right; + end case; + end In_Range; + + function Build_Discrete_Range_Type + (L : Int64; R : Int64; Dir : Direction_Type) return Discrete_Range_Type is + begin + return (Dir => Dir, + Left => L, + Right => R, + Is_Signed => L < 0 or R < 0); + end Build_Discrete_Range_Type; + + function Create_Bit_Type return Type_Acc + is + subtype Bit_Type_Type is Type_Type (Type_Bit); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Bit_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Bit, + Is_Synth => True, + Al => 0, + Sz => 1, + W => 1))); + end Create_Bit_Type; + + function Create_Logic_Type return Type_Acc + is + subtype Logic_Type_Type is Type_Type (Type_Logic); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Logic_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Logic, + Is_Synth => True, + Al => 0, + Sz => 1, + W => 1))); + end Create_Logic_Type; + + function Create_Discrete_Type (Rng : Discrete_Range_Type; + Sz : Size_Type; + W : Uns32) + return Type_Acc + is + subtype Discrete_Type_Type is Type_Type (Type_Discrete); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Discrete_Type_Type); + Al : Palign_Type; + begin + if Sz <= 1 then + Al := 0; + elsif Sz <= 4 then + Al := 2; + else + pragma Assert (Sz <= 8); + Al := 3; + end if; + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Discrete, + Is_Synth => True, + Al => Al, + Sz => Sz, + W => W, + Drange => Rng))); + end Create_Discrete_Type; + + function Create_Float_Type (Rng : Float_Range_Type) return Type_Acc + is + subtype Float_Type_Type is Type_Type (Type_Float); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Float_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Float, + Is_Synth => True, + Al => 3, + Sz => 8, + W => 64, + Frange => Rng))); + end Create_Float_Type; + + function Create_Vector_Type (Bnd : Bound_Type; El_Type : Type_Acc) + return Type_Acc + is + subtype Vector_Type_Type is Type_Type (Type_Vector); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Vector_Type_Type); + begin + return To_Type_Acc + (Alloc (Current_Pool, (Kind => Type_Vector, + Is_Synth => True, + Al => El_Type.Al, + Sz => El_Type.Sz * Size_Type (Bnd.Len), + W => Bnd.Len, + Vbound => Bnd, + Vec_El => El_Type))); + end Create_Vector_Type; + + function Create_Slice_Type (Len : Uns32; El_Type : Type_Acc) + return Type_Acc + is + subtype Slice_Type_Type is Type_Type (Type_Slice); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Slice_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, + (Kind => Type_Slice, + Is_Synth => El_Type.Is_Synth, + Al => El_Type.Al, + Sz => Size_Type (Len) * El_Type.Sz, + W => Len * El_Type.W, + Slice_El => El_Type))); + end Create_Slice_Type; + + function Create_Vec_Type_By_Length (Len : Uns32; El : Type_Acc) + return Type_Acc is + begin + return Create_Vector_Type ((Dir => Dir_Downto, + Left => Int32 (Len) - 1, + Right => 0, + Len => Len), + El); + end Create_Vec_Type_By_Length; + + function Create_Bound_Array (Ndims : Dim_Type) return Bound_Array_Acc + is + subtype Data_Type is Bound_Array (Ndims); + Res : Address; + begin + -- Manually allocate the array to handle large arrays without + -- creating a large temporary value. + Areapools.Allocate + (Current_Pool.all, Res, + Data_Type'Size / Storage_Unit, Data_Type'Alignment); + + declare + -- Discard the warnings for no pragma Import as we really want + -- to use the default initialization. + pragma Warnings (Off); + Addr1 : constant Address := Res; + Init : Data_Type; + for Init'Address use Addr1; + pragma Warnings (On); + begin + null; + end; + + return To_Bound_Array_Acc (Res); + end Create_Bound_Array; + + function Create_Array_Type (Bnd : Bound_Array_Acc; El_Type : Type_Acc) + return Type_Acc + is + subtype Array_Type_Type is Type_Type (Type_Array); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Array_Type_Type); + L : Uns32; + begin + L := 1; + for I in Bnd.D'Range loop + L := L * Bnd.D (I).Len; + end loop; + return To_Type_Acc (Alloc (Current_Pool, + (Kind => Type_Array, + Is_Synth => El_Type.Is_Synth, + Al => El_Type.Al, + Sz => El_Type.Sz * Size_Type (L), + W => El_Type.W * L, + Abounds => Bnd, + Arr_El => El_Type))); + end Create_Array_Type; + + function Create_Unbounded_Array (Ndim : Dim_Type; El_Type : Type_Acc) + return Type_Acc + is + subtype Unbounded_Type_Type is Type_Type (Type_Unbounded_Array); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Unbounded_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Array, + Is_Synth => El_Type.Is_Synth, + Al => El_Type.Al, + Sz => 0, + W => 0, + Uarr_Ndim => Ndim, + Uarr_El => El_Type))); + end Create_Unbounded_Array; + + function Create_Unbounded_Vector (El_Type : Type_Acc) return Type_Acc + is + subtype Unbounded_Type_Type is Type_Type (Type_Unbounded_Vector); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Unbounded_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Vector, + Is_Synth => El_Type.Is_Synth, + Al => El_Type.Al, + Sz => 0, + W => 0, + Uvec_El => El_Type))); + end Create_Unbounded_Vector; + + function Get_Array_Element (Arr_Type : Type_Acc) return Type_Acc is + begin + case Arr_Type.Kind is + when Type_Vector => + return Arr_Type.Vec_El; + when Type_Array => + return Arr_Type.Arr_El; + when Type_Unbounded_Array => + return Arr_Type.Uarr_El; + when Type_Unbounded_Vector => + return Arr_Type.Uvec_El; + when others => + raise Internal_Error; + end case; + end Get_Array_Element; + + function Get_Array_Bound (Typ : Type_Acc; Dim : Dim_Type) + return Bound_Type is + begin + case Typ.Kind is + when Type_Vector => + if Dim /= 1 then + raise Internal_Error; + end if; + return Typ.Vbound; + when Type_Array => + return Typ.Abounds.D (Dim); + when others => + raise Internal_Error; + end case; + end Get_Array_Bound; + + function Get_Range_Length (Rng : Discrete_Range_Type) return Uns32 + is + Len : Int64; + begin + case Rng.Dir is + when Dir_To => + Len := Rng.Right - Rng.Left + 1; + when Dir_Downto => + Len := Rng.Left - Rng.Right + 1; + end case; + if Len < 0 then + return 0; + else + return Uns32 (Len); + end if; + end Get_Range_Length; + + function Create_Rec_El_Array (Nels : Iir_Index32) return Rec_El_Array_Acc + is + subtype Data_Type is Rec_El_Array (Nels); + Res : Address; + begin + -- Manually allocate the array to handle large arrays without + -- creating a large temporary value. + Areapools.Allocate + (Current_Pool.all, Res, + Data_Type'Size / Storage_Unit, Data_Type'Alignment); + + declare + -- Discard the warnings for no pragma Import as we really want + -- to use the default initialization. + pragma Warnings (Off); + Addr1 : constant Address := Res; + Init : Data_Type; + for Init'Address use Addr1; + pragma Warnings (On); + begin + null; + end; + + return To_Rec_El_Array_Acc (Res); + end Create_Rec_El_Array; + + function Align (Off : Size_Type; Al : Palign_Type) return Size_Type + is + Mask : constant Size_Type := 2 ** Natural (Al) - 1; + begin + return (Off + Mask) and not Mask; + end Align; + + function Create_Record_Type (Els : Rec_El_Array_Acc) return Type_Acc + is + subtype Record_Type_Type is Type_Type (Type_Record); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Record_Type_Type); + Is_Synth : Boolean; + W : Uns32; + Al : Palign_Type; + Sz : Size_Type; + begin + -- Layout the record. + Is_Synth := True; + Al := 0; + Sz := 0; + W := 0; + for I in Els.E'Range loop + declare + E : Rec_El_Type renames Els.E (I); + begin + -- For nets. + E.Boff := W; + Is_Synth := Is_Synth and E.Typ.Is_Synth; + W := W + E.Typ.W; + + -- For memory. + Al := Palign_Type'Max (Al, E.Typ.Al); + Sz := Align (Sz, E.Typ.Al); + E.Moff := Sz; + Sz := Sz + E.Typ.Sz; + end; + end loop; + Sz := Align (Sz, Al); + + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Record, + Is_Synth => Is_Synth, + Al => Al, + Sz => Sz, + W => W, + Rec => Els))); + end Create_Record_Type; + + function Create_Unbounded_Record (Els : Rec_El_Array_Acc) return Type_Acc + is + subtype Unbounded_Record_Type_Type is Type_Type (Type_Unbounded_Record); + function Alloc is + new Areapools.Alloc_On_Pool_Addr (Unbounded_Record_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Record, + Is_Synth => True, + Al => 0, + Sz => 0, + W => 0, + Rec => Els))); + end Create_Unbounded_Record; + + function Create_Access_Type (Acc_Type : Type_Acc) return Type_Acc + is + subtype Access_Type_Type is Type_Type (Type_Access); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Access_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Access, + Is_Synth => False, + Al => 2, + Sz => 4, + W => 32, + Acc_Acc => Acc_Type))); + end Create_Access_Type; + + function Create_File_Type (File_Type : Type_Acc) return Type_Acc + is + subtype File_Type_Type is Type_Type (Type_File); + function Alloc is new Areapools.Alloc_On_Pool_Addr (File_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_File, + Is_Synth => False, + Al => 2, + Sz => 4, + W => 32, + File_Typ => File_Type, + File_Signature => null))); + end Create_File_Type; + + function Create_Protected_Type return Type_Acc + is + subtype Protected_Type_Type is Type_Type (Type_Protected); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Protected_Type_Type); + begin + return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Protected, + Is_Synth => False, + Al => 2, + Sz => 4, + W => 32))); + end Create_Protected_Type; + + function Vec_Length (Typ : Type_Acc) return Iir_Index32 is + begin + return Iir_Index32 (Typ.Vbound.Len); + end Vec_Length; + + function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32 is + begin + case Typ.Kind is + when Type_Vector => + return Iir_Index32 (Typ.Vbound.Len); + when Type_Array => + declare + Len : Uns32; + begin + Len := 1; + for I in Typ.Abounds.D'Range loop + Len := Len * Typ.Abounds.D (I).Len; + end loop; + return Iir_Index32 (Len); + end; + when others => + raise Internal_Error; + end case; + end Get_Array_Flat_Length; + + function Get_Type_Width (Atype : Type_Acc) return Uns32 is + begin + pragma Assert (Atype.Kind /= Type_Unbounded_Array); + return Atype.W; + end Get_Type_Width; + + function Get_Bound_Length (T : Type_Acc; Dim : Dim_Type) return Uns32 is + begin + case T.Kind is + when Type_Vector => + if Dim /= 1 then + raise Internal_Error; + end if; + return T.Vbound.Len; + when Type_Slice => + if Dim /= 1 then + raise Internal_Error; + end if; + return T.W; + when Type_Array => + return T.Abounds.D (Dim).Len; + when others => + raise Internal_Error; + end case; + end Get_Bound_Length; + + function Is_Matching_Bounds (L, R : Type_Acc) return Boolean is + begin + case L.Kind is + when Type_Bit + | Type_Logic + | Type_Discrete + | Type_Float => + pragma Assert (L.Kind = R.Kind); + return True; + when Type_Vector + | Type_Slice => + return Get_Bound_Length (L, 1) = Get_Bound_Length (R, 1); + when Type_Array => + for I in L.Abounds.D'Range loop + if Get_Bound_Length (L, I) /= Get_Bound_Length (R, I) then + return False; + end if; + end loop; + return True; + when Type_Unbounded_Array + | Type_Unbounded_Vector + | Type_Unbounded_Record => + raise Internal_Error; + when Type_Record => + -- FIXME: handle vhdl-08 + return True; + when Type_Access => + return True; + when Type_File + | Type_Protected => + raise Internal_Error; + end case; + end Is_Matching_Bounds; + + function Read_U8 (Mt : Memtyp) return Ghdl_U8 + is + pragma Assert (Mt.Typ.Sz = 1); + begin + return Read_U8 (Mt.Mem); + end Read_U8; + + + function Read_Fp64 (Mt : Memtyp) return Fp64 is + begin + return Read_Fp64 (Mt.Mem); + end Read_Fp64; + + function Read_Discrete (Mt : Memtyp) return Int64 is + begin + case Mt.Typ.Sz is + when 1 => + return Int64 (Read_U8 (Mt.Mem)); + when 4 => + return Int64 (Read_I32 (Mt.Mem)); + when 8 => + return Int64 (Read_I64 (Mt.Mem)); + when others => + raise Internal_Error; + end case; + end Read_Discrete; + + procedure Write_Discrete (Mem : Memory_Ptr; Typ : Type_Acc; Val : Int64) is + begin + case Typ.Sz is + when 1 => + Write_U8 (Mem, Ghdl_U8 (Val)); + when 4 => + Write_I32 (Mem, Ghdl_I32 (Val)); + when 8 => + Write_I64 (Mem, Ghdl_I64 (Val)); + when others => + raise Internal_Error; + end case; + end Write_Discrete; + + function Alloc_Memory (Vtype : Type_Acc) return Memory_Ptr + is + function To_Memory_Ptr is new Ada.Unchecked_Conversion + (System.Address, Memory_Ptr); + M : System.Address; + begin + Areapools.Allocate (Current_Pool.all, M, + Vtype.Sz, Size_Type (2 ** Natural (Vtype.Al))); + return To_Memory_Ptr (M); + end Alloc_Memory; + + function Create_Memory (Vtype : Type_Acc) return Memtyp is + begin + return (Vtype, Alloc_Memory (Vtype)); + end Create_Memory; + + function Create_Memory_Zero (Vtype : Type_Acc) return Memtyp + is + Mem : Memory_Ptr; + begin + Mem := Alloc_Memory (Vtype); + for I in 1 .. Vtype.Sz loop + Write_U8 (Mem + (I - 1), 0); + end loop; + return (Vtype, Mem); + end Create_Memory_Zero; + + function Create_Memory_U8 (Val : Ghdl_U8; Vtype : Type_Acc) + return Memtyp + is + pragma Assert (Vtype.Sz = 1); + Res : Memory_Ptr; + begin + Res := Alloc_Memory (Vtype); + Write_U8 (Res, Val); + return (Vtype, Res); + end Create_Memory_U8; + + function Create_Memory_Fp64 (Val : Fp64; Vtype : Type_Acc) + return Memtyp + is + pragma Assert (Vtype.Sz = 8); + Res : Memory_Ptr; + begin + Res := Alloc_Memory (Vtype); + Write_Fp64 (Res, Val); + return (Vtype, Res); + end Create_Memory_Fp64; + + function Create_Memory_Discrete (Val : Int64; Vtype : Type_Acc) + return Memtyp + is + Res : Memory_Ptr; + begin + Res := Alloc_Memory (Vtype); + case Vtype.Sz is + when 1 => + Write_U8 (Res, Ghdl_U8 (Val)); + when 4 => + Write_I32 (Res, Ghdl_I32 (Val)); + when 8 => + Write_I64 (Res, Ghdl_I64 (Val)); + when others => + raise Internal_Error; + end case; + return (Vtype, Res); + end Create_Memory_Discrete; + + function Is_Equal (L, R : Memtyp) return Boolean is + begin + if L = R then + return True; + end if; + + if L.Typ.Sz /= R.Typ.Sz then + return False; + end if; + + -- FIXME: not correct for records, not correct for floats! + for I in 1 .. L.Typ.Sz loop + if L.Mem (I - 1) /= R.Mem (I - 1) then + return False; + end if; + end loop; + return True; + end Is_Equal; + + procedure Copy_Memory (Dest : Memory_Ptr; Src : Memory_Ptr; Sz : Size_Type) + is + begin + for I in 1 .. Sz loop + Dest (I - 1) := Src (I - 1); + end loop; + end Copy_Memory; + + function Unshare (Src : Memtyp) return Memtyp + is + Res : Memory_Ptr; + begin + Res := Alloc_Memory (Src.Typ); + Copy_Memory (Res, Src.Mem, Src.Typ.Sz); + return (Src.Typ, Res); + end Unshare; + + Bit0_Mem : constant Memory_Element := 0; + Bit1_Mem : constant Memory_Element := 1; + + function To_Memory_Ptr is new Ada.Unchecked_Conversion + (Address, Memory_Ptr); + + procedure Init is + begin + Instance_Pool := Global_Pool'Access; + Boolean_Type := Create_Bit_Type; + Logic_Type := Create_Logic_Type; + Bit_Type := Create_Bit_Type; + + Bit0 := (Bit_Type, To_Memory_Ptr (Bit0_Mem'Address)); + Bit1 := (Bit_Type, To_Memory_Ptr (Bit1_Mem'Address)); + end Init; +end Elab.Vhdl_Objtypes; diff --git a/src/synth/elab-vhdl_objtypes.ads b/src/synth/elab-vhdl_objtypes.ads new file mode 100644 index 000000000..46f088dfd --- /dev/null +++ b/src/synth/elab-vhdl_objtypes.ads @@ -0,0 +1,297 @@ +-- Values in 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 Areapools; use Areapools; + +with Grt.Types; use Grt.Types; + +with Elab.Memtype; use Elab.Memtype; + +with Vhdl.Nodes; use Vhdl.Nodes; + +package Elab.Vhdl_Objtypes is + type Discrete_Range_Type is record + -- An integer range. + Dir : Direction_Type; + + -- Netlist representation: signed or unsigned, width of vector. + Is_Signed : Boolean; + + Left : Int64; + Right : Int64; + end record; + + -- Return the width of RNG. + function Discrete_Range_Width (Rng : Discrete_Range_Type) return Uns32; + + function Build_Discrete_Range_Type + (L : Int64; R : Int64; Dir : Direction_Type) return Discrete_Range_Type; + + type Float_Range_Type is record + Dir : Direction_Type; + Left : Fp64; + Right : Fp64; + end record; + + type Bound_Type is record + Dir : Direction_Type; + Left : Int32; + Right : Int32; + Len : Uns32; + end record; + + type Bound_Array_Type is array (Dim_Type range <>) of Bound_Type; + + type Bound_Array (Ndim : Dim_Type) is record + D : Bound_Array_Type (1 .. Ndim); + end record; + + type Bound_Array_Acc is access Bound_Array; + + type Type_Kind is + ( + Type_Bit, + Type_Logic, + Type_Discrete, + Type_Float, + Type_Vector, + Type_Unbounded_Vector, + + -- A slice is for a slice of vector with dynamic bounds. So the bounds + -- of the result aren't known, but its width is. + Type_Slice, + Type_Array, + Type_Unbounded_Array, + Type_Unbounded_Record, + Type_Record, + + Type_Access, + Type_File, + Type_Protected + ); + + subtype Type_Nets is Type_Kind range Type_Bit .. Type_Logic; + subtype Type_All_Discrete is Type_Kind range Type_Bit .. Type_Discrete; + subtype Type_Records is + Type_Kind range Type_Unbounded_Record .. Type_Record; + + type Type_Type (Kind : Type_Kind); + type Type_Acc is access Type_Type; + + type Rec_El_Type is record + -- Bit offset: offset of the element in a net. + Boff : Uns32; + + -- Memory offset: offset of the element in memory. + Moff : Size_Type; + + -- Type of the element. + Typ : Type_Acc; + end record; + + type Rec_El_Array_Type is array (Iir_Index32 range <>) of Rec_El_Type; + type Rec_El_Array (Len : Iir_Index32) is record + E : Rec_El_Array_Type (1 .. Len); + end record; + + type Rec_El_Array_Acc is access Rec_El_Array; + + -- Power of 2 alignment. + type Palign_Type is range 0 .. 3; + + type Type_Type (Kind : Type_Kind) is record + -- False if the type is not synthesisable: is or contains access/file. + Is_Synth : Boolean; + + -- Alignment (in bytes) for this type. + Al : Palign_Type; + + -- Number of bytes (when in memory) for this type. + Sz : Size_Type; + + -- Number of bits (when in a net) for this type. + -- Can be zero only if the type has only 0 or 1 value (like a discrete + -- type with 1 element, a null vector, or a null array). + -- For non synthesizable types (like files or protected type), just + -- use 32. + W : Uns32; + + case Kind is + when Type_Bit + | Type_Logic => + null; + when Type_Discrete => + Drange : Discrete_Range_Type; + when Type_Float => + Frange : Float_Range_Type; + when Type_Vector => + Vbound : Bound_Type; + Vec_El : Type_Acc; + when Type_Unbounded_Vector => + Uvec_El : Type_Acc; + when Type_Slice => + Slice_El : Type_Acc; + when Type_Array => + Abounds : Bound_Array_Acc; + Arr_El : Type_Acc; + when Type_Unbounded_Array => + Uarr_Ndim : Dim_Type; + Uarr_El : Type_Acc; + when Type_Record + | Type_Unbounded_Record => + Rec : Rec_El_Array_Acc; + when Type_Access => + Acc_Acc : Type_Acc; + when Type_File => + File_Typ : Type_Acc; + File_Signature : String_Acc; + when Type_Protected => + null; + end case; + end record; + + type Memtyp is record + Typ : Type_Acc; + Mem : Memory_Ptr; + end record; + + Null_Memtyp : constant Memtyp := (null, null); + + -- Offsets for a value. + type Value_Offsets is record + Net_Off : Uns32; + Mem_Off : Size_Type; + end record; + + No_Value_Offsets : constant Value_Offsets := (0, 0); + + function "+" (L, R : Value_Offsets) return Value_Offsets; + + Global_Pool : aliased Areapool; + Expr_Pool : aliased Areapool; + + -- Areapool used by Create_*_Value + Current_Pool : Areapool_Acc := Expr_Pool'Access; + + -- Pool for objects allocated in the current instance. + Instance_Pool : Areapool_Acc; + + -- Types. + function Create_Discrete_Type (Rng : Discrete_Range_Type; + Sz : Size_Type; + W : Uns32) + return Type_Acc; + + function Create_Float_Type (Rng : Float_Range_Type) return Type_Acc; + function Create_Vec_Type_By_Length (Len : Uns32; El : Type_Acc) + return Type_Acc; + function Create_Vector_Type (Bnd : Bound_Type; El_Type : Type_Acc) + return Type_Acc; + function Create_Unbounded_Vector (El_Type : Type_Acc) return Type_Acc; + function Create_Slice_Type (Len : Uns32; El_Type : Type_Acc) + return Type_Acc; + function Create_Bound_Array (Ndims : Dim_Type) return Bound_Array_Acc; + function Create_Array_Type (Bnd : Bound_Array_Acc; El_Type : Type_Acc) + return Type_Acc; + function Create_Unbounded_Array (Ndim : Dim_Type; El_Type : Type_Acc) + return Type_Acc; + function Create_Rec_El_Array (Nels : Iir_Index32) return Rec_El_Array_Acc; + + function Create_Record_Type (Els : Rec_El_Array_Acc) return Type_Acc; + function Create_Unbounded_Record (Els : Rec_El_Array_Acc) return Type_Acc; + + function Create_Access_Type (Acc_Type : Type_Acc) return Type_Acc; + + function Create_File_Type (File_Type : Type_Acc) return Type_Acc; + + function Create_Protected_Type return Type_Acc; + + function In_Bounds (Bnd : Bound_Type; V : Int32) return Boolean; + function In_Range (Rng : Discrete_Range_Type; V : Int64) return Boolean; + + -- Return the bounds of dimension DIM of a vector/array. For a vector, + -- DIM must be 1. + function Get_Array_Bound (Typ : Type_Acc; Dim : Dim_Type) + return Bound_Type; + + -- Return the length of RNG. + function Get_Range_Length (Rng : Discrete_Range_Type) return Uns32; + + -- Return the element of a vector/array/unbounded_array. + function Get_Array_Element (Arr_Type : Type_Acc) return Type_Acc; + + function Is_Bounded_Type (Typ : Type_Acc) return Boolean; + + function Are_Types_Equal (L, R : Type_Acc) return Boolean; + + -- Return the length of a vector type. + function Vec_Length (Typ : Type_Acc) return Iir_Index32; + + -- Get the number of indexes in array type TYP without counting + -- sub-elements. + function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32; + + -- Return length of dimension DIM of type T. + function Get_Bound_Length (T : Type_Acc; Dim : Dim_Type) return Uns32; + + function Is_Matching_Bounds (L, R : Type_Acc) return Boolean; + + function Get_Type_Width (Atype : Type_Acc) return Uns32; + + -- Low-level functions + + function Read_U8 (Mt : Memtyp) return Ghdl_U8; + function Read_Fp64 (Mt : Memtyp) return Fp64; + + procedure Write_Discrete (Mem : Memory_Ptr; Typ : Type_Acc; Val : Int64); + function Read_Discrete (Mt : Memtyp) return Int64; + + -- Memory allocation. + + function Create_Memory_U8 (Val : Ghdl_U8; Vtype : Type_Acc) + return Memtyp; + function Create_Memory_Fp64 (Val : Fp64; Vtype : Type_Acc) + return Memtyp; + function Create_Memory_Discrete (Val : Int64; Vtype : Type_Acc) + return Memtyp; + + function Alloc_Memory (Vtype : Type_Acc) return Memory_Ptr; + function Create_Memory (Vtype : Type_Acc) return Memtyp; + + -- Like Create_Memory but initialize to 0. To be used only for types + -- of width 0. + function Create_Memory_Zero (Vtype : Type_Acc) return Memtyp; + + function Is_Equal (L, R : Memtyp) return Boolean; + + procedure Copy_Memory (Dest : Memory_Ptr; Src : Memory_Ptr; Sz : Size_Type); + + function Unshare (Src : Memtyp) return Memtyp; + + procedure Init; + + -- Set by Init. + Boolean_Type : Type_Acc := null; + Logic_Type : Type_Acc := null; + Bit_Type : Type_Acc := null; + + -- Also set by init. + Bit0 : Memtyp; + Bit1 : Memtyp; +end Elab.Vhdl_Objtypes; diff --git a/src/synth/elab-vhdl_stmts.adb b/src/synth/elab-vhdl_stmts.adb new file mode 100644 index 000000000..d3667b0e4 --- /dev/null +++ b/src/synth/elab-vhdl_stmts.adb @@ -0,0 +1,231 @@ +-- Elaborate statements +-- Copyright (C) 2021 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 Vhdl.Errors; use Vhdl.Errors; +with Vhdl.Utils; use Vhdl.Utils; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Vhdl_Decls; use Elab.Vhdl_Decls; +with Elab.Vhdl_Insts; use Elab.Vhdl_Insts; +with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; + +package body Elab.Vhdl_Stmts is + function Elab_Generate_Statement_Body (Syn_Inst : Synth_Instance_Acc; + Bod : Node; + Config : Node; + Iterator : Node := Null_Node; + Iterator_Val : Valtyp := No_Valtyp) + return Synth_Instance_Acc + is + Decls_Chain : constant Node := Get_Declaration_Chain (Bod); + Bod_Inst : Synth_Instance_Acc; + begin + Bod_Inst := Make_Elab_Instance (Syn_Inst, Bod, Config); + + if Iterator /= Null_Node then + -- Add the iterator (for for-generate). + Create_Object (Bod_Inst, Iterator, Iterator_Val); + end if; + + Elab_Declarations (Bod_Inst, Decls_Chain); + + Elab_Concurrent_Statements + (Bod_Inst, Get_Concurrent_Statement_Chain (Bod)); + + return Bod_Inst; + end Elab_Generate_Statement_Body; + + procedure Elab_For_Generate_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) + is + Iterator : constant Node := Get_Parameter_Specification (Stmt); + Bod : constant Node := Get_Generate_Statement_Body (Stmt); + Configs : constant Node := Get_Generate_Block_Configuration (Bod); + It_Type : constant Node := Get_Declaration_Type (Iterator); + Gen_Inst : Synth_Instance_Acc; + Sub_Inst : Synth_Instance_Acc; + Config : Node; + It_Rng : Type_Acc; + Val : Valtyp; + Ival : Valtyp; + Len : Uns32; + begin + if It_Type /= Null_Node then + Synth_Subtype_Indication (Syn_Inst, It_Type); + end if; + + -- Initial value. + It_Rng := Get_Subtype_Object (Syn_Inst, Get_Type (Iterator)); + Len := Get_Range_Length (It_Rng.Drange); + Val := Create_Value_Discrete (It_Rng.Drange.Left, It_Rng); + + Gen_Inst := Make_Elab_Generate_Instance + (Syn_Inst, Stmt, Configs, Natural (Len)); + + Create_Sub_Instance (Syn_Inst, Stmt, Gen_Inst); + + for I in 1 .. Len loop + -- Find and apply the config block. + declare + Spec : Node; + begin + Config := Configs; + while Config /= Null_Node loop + Spec := Get_Block_Specification (Config); + case Get_Kind (Spec) is + when Iir_Kind_Simple_Name => + exit; + when others => + Error_Kind ("elab_for_generate_statement", Spec); + end case; + Config := Get_Prev_Block_Configuration (Config); + end loop; + Apply_Block_Configuration (Config, Bod); + end; + + -- Create a copy of the current iterator value for the generate + -- block. + Ival := Create_Value_Discrete (Read_Discrete (Val), It_Rng); + + Sub_Inst := Elab_Generate_Statement_Body + (Syn_Inst, Bod, Config, Iterator, Ival); + Set_Generate_Sub_Instance (Gen_Inst, Positive (I), Sub_Inst); + + Update_Index (It_Rng.Drange, Val); + end loop; + end Elab_For_Generate_Statement; + + procedure Elab_If_Generate_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) + is + Gen : Node; + Bod : Node; + Icond : Node; + Cond : Valtyp; + Config : Node; + Sub_Inst : Synth_Instance_Acc; + begin + Gen := Stmt; + + loop + Icond := Get_Condition (Gen); + if Icond /= Null_Node then + Cond := Exec_Expression (Syn_Inst, Icond); + Strip_Const (Cond); + else + -- It is the else generate. + Cond := No_Valtyp; + end if; + if Cond = No_Valtyp or else Read_Discrete (Cond) = 1 then + Bod := Get_Generate_Statement_Body (Gen); + Config := Get_Generate_Block_Configuration (Bod); + + Apply_Block_Configuration (Config, Bod); + Sub_Inst := Elab_Generate_Statement_Body (Syn_Inst, Bod, Config); + Create_Sub_Instance (Syn_Inst, Bod, Sub_Inst); + return; + end if; + Gen := Get_Generate_Else_Clause (Gen); + exit when Gen = Null_Node; + end loop; + + -- Not generated. + Create_Sub_Instance (Syn_Inst, Stmt, null); + end Elab_If_Generate_Statement; + + procedure Elab_Block_Statement (Syn_Inst : Synth_Instance_Acc; Blk : Node) + is + Blk_Inst : Synth_Instance_Acc; + begin + -- No support for guard or header. + if Get_Block_Header (Blk) /= Null_Node + or else Get_Guard_Decl (Blk) /= Null_Node + then + raise Internal_Error; + end if; + + Apply_Block_Configuration + (Get_Block_Block_Configuration (Blk), Blk); + + Blk_Inst := Make_Elab_Instance (Syn_Inst, Blk, Null_Iir); + Create_Sub_Instance (Syn_Inst, Blk, Blk_Inst); + + Elab_Declarations (Blk_Inst, Get_Declaration_Chain (Blk)); + Elab_Concurrent_Statements + (Blk_Inst, Get_Concurrent_Statement_Chain (Blk)); + end Elab_Block_Statement; + + procedure Elab_Concurrent_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is + begin + case Get_Kind (Stmt) is + when Iir_Kinds_Process_Statement => + null; + when Iir_Kind_Concurrent_Simple_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Restrict_Directive + | Iir_Kind_Psl_Assume_Directive + | Iir_Kind_Psl_Assert_Directive + | Iir_Kind_Psl_Cover_Directive + | Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (Stmt) then + Elab_Component_Instantiation_Statement (Syn_Inst, Stmt); + else + Elab_Design_Instantiation_Statement (Syn_Inst, Stmt); + end if; + + when Iir_Kind_For_Generate_Statement => + Elab_For_Generate_Statement (Syn_Inst, Stmt); + + when Iir_Kind_If_Generate_Statement => + Elab_If_Generate_Statement (Syn_Inst, Stmt); + + when Iir_Kind_Block_Statement => + Elab_Block_Statement (Syn_Inst, Stmt); + + when others => + Error_Kind ("elab_concurrent_statement", Stmt); + end case; + end Elab_Concurrent_Statement; + + procedure Elab_Concurrent_Statements + (Syn_Inst : Synth_Instance_Acc; Chain : Node) + is + Stmt : Node; + begin + if Chain = Null_Node then + return; + end if; + + Stmt := Chain; + while Stmt /= Null_Node loop + Elab_Concurrent_Statement (Syn_Inst, Stmt); + Stmt := Get_Chain (Stmt); + end loop; + end Elab_Concurrent_Statements; +end Elab.Vhdl_Stmts; diff --git a/src/synth/elab-vhdl_stmts.ads b/src/synth/elab-vhdl_stmts.ads new file mode 100644 index 000000000..4678b092a --- /dev/null +++ b/src/synth/elab-vhdl_stmts.ads @@ -0,0 +1,29 @@ +-- Elaborate statements +-- Copyright (C) 2021 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 Elab.Vhdl_Context; use Elab.Vhdl_Context; + +package Elab.Vhdl_Stmts is + procedure Elab_Concurrent_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Node); + + procedure Elab_Concurrent_Statements + (Syn_Inst : Synth_Instance_Acc; Chain : Node); +end Elab.Vhdl_Stmts; diff --git a/src/synth/elab-vhdl_types.adb b/src/synth/elab-vhdl_types.adb new file mode 100644 index 000000000..1238bec39 --- /dev/null +++ b/src/synth/elab-vhdl_types.adb @@ -0,0 +1,562 @@ +-- Create declarations for 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 Mutils; use Mutils; + +with Vhdl.Utils; use Vhdl.Utils; +with Vhdl.Std_Package; +with Vhdl.Ieee.Std_Logic_1164; +with Vhdl.Evaluation; +with Vhdl.Errors; use Vhdl.Errors; + +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; +with Elab.Vhdl_Decls; +with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; + +package body Elab.Vhdl_Types is + function Synth_Discrete_Range_Expression + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type + is + L, R : Valtyp; + Lval, Rval : Int64; + begin + -- Static values. + L := Exec_Expression_With_Basetype (Syn_Inst, Get_Left_Limit (Rng)); + R := Exec_Expression_With_Basetype (Syn_Inst, Get_Right_Limit (Rng)); + Strip_Const (L); + Strip_Const (R); + + if not (Is_Static (L.Val) and Is_Static (R.Val)) then + Error_Msg_Elab (+Rng, "limits of range are not constant"); + Set_Error (Syn_Inst); + return (Dir => Get_Direction (Rng), + Left => 0, + Right => 0, + Is_Signed => False); + end if; + + Lval := Read_Discrete (L); + Rval := Read_Discrete (R); + return Build_Discrete_Range_Type (Lval, Rval, Get_Direction (Rng)); + end Synth_Discrete_Range_Expression; + + function Synth_Float_Range_Expression + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type + is + L, R : Valtyp; + begin + -- Static values (so no enable). + L := Exec_Expression (Syn_Inst, Get_Left_Limit (Rng)); + R := Exec_Expression (Syn_Inst, Get_Right_Limit (Rng)); + return (Get_Direction (Rng), Read_Fp64 (L), Read_Fp64 (R)); + end Synth_Float_Range_Expression; + + function Synth_Array_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) + return Bound_Type + is + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix : constant Iir := Strip_Denoting_Name (Prefix_Name); + Dim : constant Natural := + Vhdl.Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); + Typ : Type_Acc; + Val : Valtyp; + begin + -- Prefix is an array object or an array subtype. + if Get_Kind (Prefix) = Iir_Kind_Subtype_Declaration then + -- TODO: does this cover all the cases ? + Typ := Get_Subtype_Object (Syn_Inst, Get_Subtype_Indication (Prefix)); + else + Val := Exec_Name (Syn_Inst, Prefix_Name); + Typ := Val.Typ; + end if; + + return Get_Array_Bound (Typ, Dim_Type (Dim)); + end Synth_Array_Attribute; + + procedure Synth_Discrete_Range (Syn_Inst : Synth_Instance_Acc; + Bound : Node; + Rng : out Discrete_Range_Type) is + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + Rng := Synth_Discrete_Range_Expression (Syn_Inst, Bound); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + if Get_Type_Declarator (Bound) /= Null_Node then + declare + Typ : Type_Acc; + begin + -- This is a named subtype, so it has been evaluated. + Typ := Get_Subtype_Object (Syn_Inst, Bound); + Rng := Typ.Drange; + end; + else + Synth_Discrete_Range + (Syn_Inst, Get_Range_Constraint (Bound), Rng); + end if; + when Iir_Kind_Range_Array_Attribute => + declare + B : Bound_Type; + begin + B := Synth_Array_Attribute (Syn_Inst, Bound); + Rng := Build_Discrete_Range_Type + (Int64 (B.Left), Int64 (B.Right), B.Dir); + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + B : Bound_Type; + T : Int32; + begin + B := Synth_Array_Attribute (Syn_Inst, Bound); + -- Reverse + case B.Dir is + when Dir_To => + B.Dir := Dir_Downto; + when Dir_Downto => + B.Dir := Dir_To; + end case; + T := B.Right; + B.Right := B.Left; + B.Left := T; + + Rng := Build_Discrete_Range_Type + (Int64 (B.Left), Int64 (B.Right), B.Dir); + end; + when Iir_Kinds_Denoting_Name => + -- A discrete subtype name. + Synth_Discrete_Range + (Syn_Inst, Get_Subtype_Indication (Get_Named_Entity (Bound)), + Rng); + when others => + Error_Kind ("synth_discrete_range", Bound); + end case; + end Synth_Discrete_Range; + + function Synth_Bounds_From_Range (Syn_Inst : Synth_Instance_Acc; + Atype : Node) return Bound_Type + is + Rng : Discrete_Range_Type; + begin + Synth_Discrete_Range (Syn_Inst, Atype, Rng); + return (Dir => Rng.Dir, + Left => Int32 (Rng.Left), Right => Int32 (Rng.Right), + Len => Get_Range_Length (Rng)); + end Synth_Bounds_From_Range; + + procedure Synth_Subtype_Indication_If_Anonymous + (Syn_Inst : Synth_Instance_Acc; Atype : Node) is + begin + if Get_Type_Declarator (Atype) = Null_Node then + Synth_Subtype_Indication (Syn_Inst, Atype); + end if; + end Synth_Subtype_Indication_If_Anonymous; + + function Synth_Subtype_Indication_If_Anonymous + (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc is + begin + if Get_Type_Declarator (Atype) = Null_Node then + return Synth_Subtype_Indication (Syn_Inst, Atype); + else + return Get_Subtype_Object (Syn_Inst, Atype); + end if; + end Synth_Subtype_Indication_If_Anonymous; + + function Synth_Array_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc + is + El_Type : constant Node := Get_Element_Subtype (Def); + Ndims : constant Natural := Get_Nbr_Dimensions (Def); + El_Typ : Type_Acc; + Typ : Type_Acc; + begin + Synth_Subtype_Indication_If_Anonymous (Syn_Inst, El_Type); + El_Typ := Get_Subtype_Object (Syn_Inst, El_Type); + + if El_Typ.Kind in Type_Nets and then Ndims = 1 then + Typ := Create_Unbounded_Vector (El_Typ); + else + Typ := Create_Unbounded_Array (Dim_Type (Ndims), El_Typ); + end if; + return Typ; + end Synth_Array_Type_Definition; + + function Synth_Record_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc + is + El_List : constant Node_Flist := Get_Elements_Declaration_List (Def); + Rec_Els : Rec_El_Array_Acc; + El : Node; + El_Type : Node; + El_Typ : Type_Acc; + begin + Rec_Els := Create_Rec_El_Array + (Iir_Index32 (Get_Nbr_Elements (El_List))); + + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + El_Type := Get_Type (El); + El_Typ := Synth_Subtype_Indication_If_Anonymous (Syn_Inst, El_Type); + Rec_Els.E (Iir_Index32 (I + 1)).Typ := El_Typ; + end loop; + + if not Is_Fully_Constrained_Type (Def) then + return Create_Unbounded_Record (Rec_Els); + else + return Create_Record_Type (Rec_Els); + end if; + end Synth_Record_Type_Definition; + + function Synth_Access_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc + is + Des_Type : constant Node := Get_Designated_Type (Def); + Des_Typ : Type_Acc; + Typ : Type_Acc; + begin + Synth_Subtype_Indication_If_Anonymous (Syn_Inst, Des_Type); + Des_Typ := Get_Subtype_Object (Syn_Inst, Des_Type); + + Typ := Create_Access_Type (Des_Typ); + return Typ; + end Synth_Access_Type_Definition; + + function Synth_File_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc + is + File_Type : constant Node := Get_Type (Get_File_Type_Mark (Def)); + File_Typ : Type_Acc; + Typ : Type_Acc; + Sig : String_Acc; + begin + File_Typ := Get_Subtype_Object (Syn_Inst, File_Type); + + if Get_Text_File_Flag (Def) + or else + Get_Kind (File_Type) in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Sig := null; + else + declare + Sig_Str : String (1 .. Get_File_Signature_Length (File_Type) + 2); + Off : Natural := Sig_Str'First; + begin + Get_File_Signature (File_Type, Sig_Str, Off); + Sig_Str (Off + 0) := '.'; + Sig_Str (Off + 1) := ASCII.NUL; + Sig := new String'(Sig_Str); + end; + end if; + + Typ := Create_File_Type (File_Typ); + Typ.File_Signature := Sig; + + return Typ; + end Synth_File_Type_Definition; + + function Scalar_Size_To_Size (Def : Node) return Size_Type is + begin + case Get_Scalar_Size (Def) is + when Scalar_8 => + return 1; + when Scalar_16 => + return 2; + when Scalar_32 => + return 4; + when Scalar_64 => + return 8; + end case; + end Scalar_Size_To_Size; + + procedure Elab_Type_Definition (Syn_Inst : Synth_Instance_Acc; Def : Node) + is + Typ : Type_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + if Def = Vhdl.Ieee.Std_Logic_1164.Std_Ulogic_Type + or else Def = Vhdl.Ieee.Std_Logic_1164.Std_Logic_Type + then + Typ := Logic_Type; + elsif Def = Vhdl.Std_Package.Boolean_Type_Definition then + Typ := Boolean_Type; + elsif Def = Vhdl.Std_Package.Bit_Type_Definition then + Typ := Bit_Type; + else + declare + Nbr_El : constant Natural := + Get_Nbr_Elements (Get_Enumeration_Literal_List (Def)); + Rng : Discrete_Range_Type; + W : Uns32; + begin + W := Uns32 (Clog2 (Uns64 (Nbr_El))); + Rng := (Dir => Dir_To, + Is_Signed => False, + Left => 0, + Right => Int64 (Nbr_El - 1)); + Typ := Create_Discrete_Type + (Rng, Scalar_Size_To_Size (Def), W); + end; + end if; + when Iir_Kind_Array_Type_Definition => + Typ := Synth_Array_Type_Definition (Syn_Inst, Def); + when Iir_Kind_Access_Type_Definition => + Typ := Synth_Access_Type_Definition (Syn_Inst, Def); + when Iir_Kind_File_Type_Definition => + Typ := Synth_File_Type_Definition (Syn_Inst, Def); + when Iir_Kind_Record_Type_Definition => + Typ := Synth_Record_Type_Definition (Syn_Inst, Def); + when Iir_Kind_Protected_Type_Declaration => + -- TODO... + Elab.Vhdl_Decls.Elab_Declarations + (Syn_Inst, Get_Declaration_Chain (Def)); + when others => + Vhdl.Errors.Error_Kind ("synth_type_definition", Def); + end case; + if Typ /= null then + Create_Subtype_Object (Syn_Inst, Def, Typ); + end if; + end Elab_Type_Definition; + + procedure Elab_Anonymous_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node; St : Node) + is + Typ : Type_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Physical_Type_Definition => + declare + Cst : constant Node := Get_Range_Constraint (St); + L, R : Int64; + Rng : Discrete_Range_Type; + W : Uns32; + begin + L := Get_Value (Get_Left_Limit (Cst)); + R := Get_Value (Get_Right_Limit (Cst)); + Rng := Build_Discrete_Range_Type (L, R, Get_Direction (Cst)); + W := Discrete_Range_Width (Rng); + Typ := Create_Discrete_Type + (Rng, Scalar_Size_To_Size (Def), W); + end; + when Iir_Kind_Floating_Type_Definition => + declare + Cst : constant Node := Get_Range_Constraint (St); + L, R : Fp64; + Rng : Float_Range_Type; + begin + L := Get_Fp_Value (Get_Left_Limit (Cst)); + R := Get_Fp_Value (Get_Right_Limit (Cst)); + Rng := (Get_Direction (Cst), L, R); + Typ := Create_Float_Type (Rng); + end; + when Iir_Kind_Array_Type_Definition => + Typ := Synth_Array_Type_Definition (Syn_Inst, Def); + when others => + Vhdl.Errors.Error_Kind ("synth_anonymous_type_definition", Def); + end case; + Create_Subtype_Object (Syn_Inst, Def, Typ); + end Elab_Anonymous_Type_Definition; + + function Synth_Discrete_Range_Constraint + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type + is + Res : Discrete_Range_Type; + begin + Synth_Discrete_Range (Syn_Inst, Rng, Res); + return Res; + end Synth_Discrete_Range_Constraint; + + function Synth_Float_Range_Constraint + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type is + begin + case Get_Kind (Rng) is + when Iir_Kind_Range_Expression => + -- FIXME: check range. + return Synth_Float_Range_Expression (Syn_Inst, Rng); + when others => + Vhdl.Errors.Error_Kind ("synth_float_range_constraint", Rng); + end case; + end Synth_Float_Range_Constraint; + + function Has_Element_Subtype_Indication (Atype : Node) return Boolean is + begin + return Get_Array_Element_Constraint (Atype) /= Null_Node + or else + (Get_Resolution_Indication (Atype) /= Null_Node + and then + (Get_Kind (Get_Resolution_Indication (Atype)) + = Iir_Kind_Array_Element_Resolution)); + end Has_Element_Subtype_Indication; + + function Synth_Array_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc + is + El_Type : constant Node := Get_Element_Subtype (Atype); + St_Indexes : constant Node_Flist := Get_Index_Subtype_List (Atype); + Ptype : Node; + St_El : Node; + Btyp : Type_Acc; + Etyp : Type_Acc; + Bnds : Bound_Array_Acc; + begin + -- VHDL08 + if Has_Element_Subtype_Indication (Atype) then + -- This subtype has created a new anonymous subtype for the + -- element. + Synth_Subtype_Indication (Syn_Inst, El_Type); + end if; + + if not Get_Index_Constraint_Flag (Atype) then + Ptype := Get_Type (Get_Subtype_Type_Mark (Atype)); + if Get_Element_Subtype (Ptype) = Get_Element_Subtype (Atype) then + -- That's an alias. + -- FIXME: maybe a resolution function was added? + -- FIXME: also handle resolution added in element subtype. + return Get_Subtype_Object (Syn_Inst, Ptype); + end if; + end if; + + Btyp := Get_Subtype_Object (Syn_Inst, Get_Base_Type (Atype)); + case Btyp.Kind is + when Type_Unbounded_Vector => + if Get_Index_Constraint_Flag (Atype) then + St_El := Get_Index_Type (St_Indexes, 0); + return Create_Vector_Type + (Synth_Bounds_From_Range (Syn_Inst, St_El), Btyp.Uvec_El); + else + -- An alias. + -- Handle vhdl08 definition of std_logic_vector from + -- std_ulogic_vector. + return Btyp; + end if; + when Type_Unbounded_Array => + -- FIXME: partially constrained arrays, subtype in indexes... + Etyp := Get_Subtype_Object (Syn_Inst, El_Type); + if Get_Index_Constraint_Flag (Atype) then + Bnds := Create_Bound_Array + (Dim_Type (Get_Nbr_Elements (St_Indexes))); + for I in Flist_First .. Flist_Last (St_Indexes) loop + St_El := Get_Index_Type (St_Indexes, I); + Bnds.D (Dim_Type (I + 1)) := + Synth_Bounds_From_Range (Syn_Inst, St_El); + end loop; + return Create_Array_Type (Bnds, Etyp); + else + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + end Synth_Array_Subtype_Indication; + + function Synth_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc is + begin + -- TODO: handle aliases directly. + case Get_Kind (Atype) is + when Iir_Kind_Array_Subtype_Definition => + return Synth_Array_Subtype_Indication (Syn_Inst, Atype); + when Iir_Kind_Record_Subtype_Definition => + return Synth_Record_Type_Definition (Syn_Inst, Atype); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Btype : constant Type_Acc := + Get_Subtype_Object (Syn_Inst, Get_Base_Type (Atype)); + Rng : Discrete_Range_Type; + W : Uns32; + begin + if Btype.Kind in Type_Nets then + -- A subtype of a bit/logic type is still a bit/logic. + -- FIXME: bounds. + return Btype; + else + Rng := Synth_Discrete_Range_Constraint + (Syn_Inst, Get_Range_Constraint (Atype)); + W := Discrete_Range_Width (Rng); + return Create_Discrete_Type (Rng, Btype.Sz, W); + end if; + end; + when Iir_Kind_Floating_Subtype_Definition => + declare + Rng : Float_Range_Type; + begin + Rng := Synth_Float_Range_Constraint + (Syn_Inst, Get_Range_Constraint (Atype)); + return Create_Float_Type (Rng); + end; + when others => + Vhdl.Errors.Error_Kind ("synth_subtype_indication", Atype); + end case; + end Synth_Subtype_Indication; + + procedure Synth_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node) + is + Typ : Type_Acc; + begin + Typ := Synth_Subtype_Indication (Syn_Inst, Atype); + Create_Subtype_Object (Syn_Inst, Atype, Typ); + end Synth_Subtype_Indication; + + function Get_Declaration_Type (Decl : Node) return Node + is + Ind : constant Node := Get_Subtype_Indication (Decl); + Atype : Node; + begin + if Get_Is_Ref (Decl) or else Ind = Null_Iir then + -- A secondary declaration in a list. + return Null_Node; + end if; + Atype := Ind; + loop + case Get_Kind (Atype) is + when Iir_Kinds_Denoting_Name => + Atype := Get_Named_Entity (Atype); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + -- Type already declared, so already handled. + return Null_Node; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + return Atype; + when others => + Vhdl.Errors.Error_Kind ("get_declaration_type", Atype); + end case; + end loop; + end Get_Declaration_Type; + + procedure Elab_Declaration_Type + (Syn_Inst : Synth_Instance_Acc; Decl : Node) + is + Atype : constant Node := Get_Declaration_Type (Decl); + begin + if Atype = Null_Node then + -- Already elaborated. + return; + end if; + Synth_Subtype_Indication (Syn_Inst, Atype); + end Elab_Declaration_Type; +end Elab.Vhdl_Types; diff --git a/src/synth/elab-vhdl_types.ads b/src/synth/elab-vhdl_types.ads new file mode 100644 index 000000000..30ee6e0ae --- /dev/null +++ b/src/synth/elab-vhdl_types.ads @@ -0,0 +1,62 @@ +-- Create declarations for 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 Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; + +package Elab.Vhdl_Types is + -- Get the type of DECL iff it is standalone (not an already existing + -- subtype). + function Get_Declaration_Type (Decl : Node) return Node; + + -- True if the element subtype indication of ATYPE needs to be created. + function Has_Element_Subtype_Indication (Atype : Node) return Boolean; + + function Synth_Discrete_Range_Expression + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type; + function Synth_Float_Range_Expression + (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type; + + function Synth_Array_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) + return Bound_Type; + + procedure Synth_Discrete_Range (Syn_Inst : Synth_Instance_Acc; + Bound : Node; + Rng : out Discrete_Range_Type); + + function Synth_Bounds_From_Range (Syn_Inst : Synth_Instance_Acc; + Atype : Node) return Bound_Type; + + function Synth_Array_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc; + + procedure Synth_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node); + function Synth_Subtype_Indication + (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc; + + procedure Elab_Type_Definition (Syn_Inst : Synth_Instance_Acc; Def : Node); + procedure Elab_Anonymous_Type_Definition + (Syn_Inst : Synth_Instance_Acc; Def : Node; St : Node); + + -- Elaborate the type of DECL. + procedure Elab_Declaration_Type + (Syn_Inst : Synth_Instance_Acc; Decl : Node); +end Elab.Vhdl_Types; diff --git a/src/synth/elab-vhdl_values-debug.adb b/src/synth/elab-vhdl_values-debug.adb new file mode 100644 index 000000000..8792fe292 --- /dev/null +++ b/src/synth/elab-vhdl_values-debug.adb @@ -0,0 +1,208 @@ +-- Values in 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 Simple_IO; use Simple_IO; +with Utils_IO; use Utils_IO; + +with Vhdl.Nodes; use Vhdl.Nodes; + +package body Elab.Vhdl_Values.Debug is + procedure Put_Dir (Dir : Direction_Type) is + begin + case Dir is + when Dir_To => + Put ("to"); + when Dir_Downto => + Put ("downto"); + end case; + end Put_Dir; + + procedure Debug_Bound (Bnd : Bound_Type) is + begin + Put_Int32 (Bnd.Left); + Put (' '); + Put_Dir (Bnd.Dir); + Put (' '); + Put_Int32 (Bnd.Right); + Put (" [l="); + Put_Uns32 (Bnd.Len); + Put (']'); + end Debug_Bound; + + procedure Debug_Typ1 (T : Type_Acc) is + begin + case T.Kind is + when Type_Bit + | Type_Logic => + Put ("bit/logic"); + when Type_Vector => + Put ("vector ("); + Debug_Bound (T.Vbound); + Put (") of ["); + Debug_Typ1 (T.Vec_El); + Put ("]"); + when Type_Array => + Put ("arr ("); + for I in 1 .. T.Abounds.Ndim loop + if I > 1 then + Put (", "); + end if; + Debug_Bound (T.Abounds.D (I)); + end loop; + Put (") of "); + Debug_Typ1 (T.Arr_El); + when Type_Record => + Put ("rec: ("); + Put (")"); + when Type_Unbounded_Record => + Put ("unbounded record"); + when Type_Discrete => + Put ("discrete: "); + Put_Int64 (T.Drange.Left); + Put (' '); + Put_Dir (T.Drange.Dir); + Put (' '); + Put_Int64 (T.Drange.Right); + if T.Drange.Is_Signed then + Put (" [signed]"); + else + Put (" [unsigned]"); + end if; + when Type_Access => + Put ("access"); + when Type_File => + Put ("file"); + when Type_Float => + Put ("float"); + when Type_Slice => + Put ("slice"); + when Type_Unbounded_Vector => + Put ("unbounded vector"); + when Type_Unbounded_Array => + Put ("unbounded array"); + when Type_Protected => + Put ("protected"); + end case; + Put (' '); + Put (" al="); + Put_Int32 (Int32 (T.Al)); + Put (" sz="); + Put_Uns32 (Uns32 (T.Sz)); + Put (" w="); + Put_Uns32 (T.W); + end Debug_Typ1; + + procedure Debug_Typ (T : Type_Acc) is + begin + Debug_Typ1 (T); + New_Line; + end Debug_Typ; + + procedure Debug_Memtyp (M : Memtyp) is + begin + case M.Typ.Kind is + when Type_Bit + | Type_Logic => + Put ("bit/logic"); + when Type_Vector => + Put ("vector ("); + Debug_Bound (M.Typ.Vbound); + Put ("): "); + for I in 1 .. M.Typ.Vbound.Len loop + Put_Uns32 (Uns32 (Read_U8 (M.Mem + Size_Type (I - 1)))); + end loop; + when Type_Array => + Put ("arr ("); + for I in 1 .. M.Typ.Abounds.Ndim loop + if I > 1 then + Put (", "); + end if; + Debug_Bound (M.Typ.Abounds.D (I)); + end loop; + Put ("): "); + for I in 1 .. Get_Array_Flat_Length (M.Typ) loop + if I > 1 then + Put (", "); + end if; + Debug_Memtyp + ((M.Typ.Arr_El, M.Mem + Size_Type (I - 1) * M.Typ.Arr_El.Sz)); + end loop; + when Type_Record => + Put ("rec: ("); + for I in M.Typ.Rec.E'Range loop + if I > 1 then + Put (", "); + end if; + Debug_Memtyp + ((M.Typ.Rec.E (I).Typ, M.Mem + M.Typ.Rec.E (I).Moff)); + end loop; + Put (")"); + when Type_Discrete => + Put ("discrete: "); + Put_Int64 (Read_Discrete (M)); + when Type_Access => + Put ("access"); + when Type_File => + Put ("file"); + when Type_Float => + Put ("float"); + when Type_Slice => + Put ("slice"); + when Type_Unbounded_Vector => + Put ("unbounded vector"); + when Type_Unbounded_Array => + Put ("unbounded array"); + when Type_Unbounded_Record => + Put ("unbounded record"); + when Type_Protected => + Put ("protected"); + end case; + New_Line; + end Debug_Memtyp; + + procedure Debug_Valtyp (V : Valtyp) is + begin + case V.Val.Kind is + when Value_Memory + | Value_Const => + Debug_Memtyp (Get_Memtyp (V)); + when Value_Net => + Put ("net "); + Put_Uns32 (V.Val.N); + Put (' '); + Debug_Typ1 (V.Typ); + New_Line; + when Value_Signal => + Put ("signal "); + Debug_Typ1 (V.Typ); + New_Line; + when Value_Wire => + Put ("wire "); + Put_Uns32 (V.Val.N); + New_Line; + when Value_File => + Put_Line ("a file"); + when Value_Alias => + Put ("an alias: "); + Debug_Typ1 (V.Typ); + Put (" of "); + Debug_Valtyp ((V.Typ, V.Val.A_Obj)); + end case; + end Debug_Valtyp; + +end Elab.Vhdl_Values.Debug; diff --git a/src/synth/elab-vhdl_values-debug.ads b/src/synth/elab-vhdl_values-debug.ads new file mode 100644 index 000000000..6972a1b3e --- /dev/null +++ b/src/synth/elab-vhdl_values-debug.ads @@ -0,0 +1,23 @@ +-- Values in 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 . + +package Elab.Vhdl_Values.Debug is + procedure Debug_Valtyp (V : Valtyp); + procedure Debug_Memtyp (M : Memtyp); + procedure Debug_Typ (T : Type_Acc); +end Elab.Vhdl_Values.Debug; diff --git a/src/synth/elab-vhdl_values.adb b/src/synth/elab-vhdl_values.adb new file mode 100644 index 000000000..90e72f223 --- /dev/null +++ b/src/synth/elab-vhdl_values.adb @@ -0,0 +1,500 @@ +-- Values in 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 Ada.Unchecked_Conversion; +with System; + +with Grt.Types; use Grt.Types; + +package body Elab.Vhdl_Values is + function To_Value_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Acc); + + function Is_Static (Val : Value_Acc) return Boolean is + begin + case Val.Kind is + when Value_Memory => + return True; + when Value_Net + | Value_Wire + | Value_Signal => + return False; + when Value_File => + return True; + when Value_Alias => + return Is_Static (Val.A_Obj); + when Value_Const => + return True; + end case; + end Is_Static; + + function Strip_Alias_Const (V : Value_Acc) return Value_Acc + is + Res : Value_Acc; + begin + Res := V; + loop + case Res.Kind is + when Value_Const => + Res := Res.C_Val; + when Value_Alias => + if Res.A_Off /= (0, 0) then + raise Internal_Error; + end if; + Res := Res.A_Obj; + when others => + return Res; + end case; + end loop; + end Strip_Alias_Const; + + function Strip_Alias_Const (V : Valtyp) return Valtyp is + begin + return (V.Typ, Strip_Alias_Const (V.Val)); + end Strip_Alias_Const; + + function Is_Equal (L, R : Valtyp) return Boolean is + begin + return Is_Equal (Get_Memtyp (L), Get_Memtyp (R)); + end Is_Equal; + + function Create_Value_Memtyp (Mt : Memtyp) return Valtyp + is + subtype Value_Type_Memory is Value_Type (Value_Memory); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); + Res : Value_Acc; + begin + Res := To_Value_Acc (Alloc (Current_Pool, (Kind => Value_Memory, + Mem => Mt.Mem))); + return (Mt.Typ, Res); + end Create_Value_Memtyp; + + function Create_Value_Wire (S : Uns32) return Value_Acc + is + subtype Value_Type_Wire is Value_Type (Value_Wire); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Wire); + begin + return To_Value_Acc + (Alloc (Current_Pool, (Kind => Value_Wire, N => S))); + end Create_Value_Wire; + + function Create_Value_Net (S : Uns32) return Value_Acc + is + subtype Value_Type_Net is Value_Type (Value_Net); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Net); + begin + return To_Value_Acc + (Alloc (Current_Pool, Value_Type_Net'(Kind => Value_Net, N => S))); + end Create_Value_Net; + + function Create_Value_Signal (S : Uns32; Init : Value_Acc) return Value_Acc + is + subtype Value_Type_Signal is Value_Type (Value_Signal); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Signal); + begin + return To_Value_Acc + (Alloc (Current_Pool, Value_Type_Signal'(Kind => Value_Signal, + S => S, + Init => Init))); + end Create_Value_Signal; + + function Create_Value_Memory (Vtype : Type_Acc) return Valtyp + is + subtype Value_Type_Memory is Value_Type (Value_Memory); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); + function To_Memory_Ptr is new Ada.Unchecked_Conversion + (System.Address, Memory_Ptr); + V : Value_Acc; + M : System.Address; + begin + Areapools.Allocate (Current_Pool.all, M, + Vtype.Sz, Size_Type (2 ** Natural (Vtype.Al))); + V := To_Value_Acc + (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory, + Mem => To_Memory_Ptr (M)))); + + return (Vtype, V); + end Create_Value_Memory; + + function Create_Value_Memory (Mt : Memtyp) return Valtyp + is + subtype Value_Type_Memory is Value_Type (Value_Memory); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); + V : Value_Acc; + begin + V := To_Value_Acc + (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory, + Mem => Mt.Mem))); + + return (Mt.Typ, V); + end Create_Value_Memory; + + function Create_Value_File (File : File_Index) return Value_Acc + is + subtype Value_Type_File is Value_Type (Value_File); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_File); + begin + return To_Value_Acc (Alloc (Current_Pool, + (Kind => Value_File, File => File))); + end Create_Value_File; + + function Create_Value_File (Vtype : Type_Acc; File : File_Index) + return Valtyp + is + pragma Assert (Vtype /= null); + begin + return (Vtype, Create_Value_File (File)); + end Create_Value_File; + + function Vec_Length (Typ : Type_Acc) return Iir_Index32 is + begin + return Iir_Index32 (Typ.Vbound.Len); + end Vec_Length; + + function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32 is + begin + case Typ.Kind is + when Type_Vector => + return Iir_Index32 (Typ.Vbound.Len); + when Type_Array => + declare + Len : Uns32; + begin + Len := 1; + for I in Typ.Abounds.D'Range loop + Len := Len * Typ.Abounds.D (I).Len; + end loop; + return Iir_Index32 (Len); + end; + when others => + raise Internal_Error; + end case; + end Get_Array_Flat_Length; + + function Create_Value_Alias + (Obj : Valtyp; Off : Value_Offsets; Typ : Type_Acc) return Valtyp + is + pragma Assert (Typ /= null); + subtype Value_Type_Alias is Value_Type (Value_Alias); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Alias); + Val : Value_Acc; + begin + Val := To_Value_Acc (Alloc (Current_Pool, + (Kind => Value_Alias, + A_Obj => Obj.Val, + A_Typ => Obj.Typ, + A_Off => Off))); + return (Typ, Val); + end Create_Value_Alias; + + function Create_Value_Const (Val : Value_Acc; Loc : Node) return Value_Acc + is + subtype Value_Type_Const is Value_Type (Value_Const); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Const); + begin + pragma Assert (Val = null or else Val.Kind /= Value_Const); + return To_Value_Acc (Alloc (Current_Pool, + (Kind => Value_Const, + C_Val => Val, + C_Loc => Loc, + C_Net => 0))); + end Create_Value_Const; + + function Create_Value_Const (Val : Valtyp; Loc : Node) return Valtyp is + begin + return (Val.Typ, Create_Value_Const (Val.Val, Loc)); + end Create_Value_Const; + + procedure Strip_Const (Vt : in out Valtyp) is + begin + if Vt.Val.Kind = Value_Const then + Vt.Val := Vt.Val.C_Val; + end if; + end Strip_Const; + + procedure Write_Value (Dest : Memory_Ptr; Vt : Valtyp) + is + Mt : Memtyp; + begin + Mt := Get_Memtyp (Vt); + Copy_Memory (Dest, Mt.Mem, Mt.Typ.Sz); + end Write_Value; + + function Copy (Src : Valtyp) return Valtyp + is + Res : Valtyp; + begin + case Src.Val.Kind is + when Value_Memory => + Res := Create_Value_Memory (Src.Typ); + for I in 1 .. Src.Typ.Sz loop + Res.Val.Mem (I - 1) := Src.Val.Mem (I - 1); + end loop; + when Value_Net => + Res := (Src.Typ, Create_Value_Net (Src.Val.S)); + when Value_Wire => + Res := (Src.Typ, Create_Value_Wire (Src.Val.S)); + when Value_File => + Res := Create_Value_File (Src.Typ, Src.Val.File); + when Value_Signal => + raise Internal_Error; + when Value_Const => + raise Internal_Error; + when Value_Alias => + raise Internal_Error; + end case; + return Res; + end Copy; + + function Unshare (Src : Valtyp; Pool : Areapool_Acc) return Valtyp + is + Prev_Pool : constant Areapool_Acc := Current_Pool; + Res : Valtyp; + begin + Current_Pool := Pool; + Res := Copy (Src); + Current_Pool := Prev_Pool; + return Res; + end Unshare; + + procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index) + is + V : Heap_Index; + for V'Address use Mem.all'Address; + pragma Import (Ada, V); + begin + V := Val; + end Write_Access; + + function Read_Access (Mem : Memory_Ptr) return Heap_Index + is + V : Heap_Index; + for V'Address use Mem.all'Address; + pragma Import (Ada, V); + begin + return V; + end Read_Access; + + function Read_Access (Mt : Memtyp) return Heap_Index is + begin + return Read_Access (Mt.Mem); + end Read_Access; + + procedure Write_Discrete (Vt : Valtyp; Val : Int64) is + begin + Write_Discrete (Vt.Val.Mem, Vt.Typ, Val); + end Write_Discrete; + + function Read_Discrete (Vt : Valtyp) return Int64 is + begin + return Read_Discrete (Get_Memtyp (Vt)); + end Read_Discrete; + + function Create_Value_Float (Val : Fp64; Vtype : Type_Acc) return Valtyp + is + Res : Valtyp; + pragma Assert (Vtype /= null); + begin + Res := Create_Value_Memory (Vtype); + Write_Fp64 (Res.Val.Mem, Val); + return Res; + end Create_Value_Float; + + function Read_Fp64 (Vt : Valtyp) return Fp64 is + begin + pragma Assert (Vt.Typ.Kind = Type_Float); + pragma Assert (Vt.Typ.Sz = 8); + return Read_Fp64 (Vt.Val.Mem); + end Read_Fp64; + + function Read_Access (Vt : Valtyp) return Heap_Index is + begin + pragma Assert (Vt.Typ.Kind = Type_Access); + return Read_Access (Vt.Val.Mem); + end Read_Access; + + function Create_Value_Discrete (Val : Int64; Vtype : Type_Acc) return Valtyp + is + Res : Valtyp; + begin + Res := Create_Value_Memory (Vtype); + case Vtype.Sz is + when 1 => + Write_U8 (Res.Val.Mem, Ghdl_U8 (Val)); + when 4 => + Write_I32 (Res.Val.Mem, Ghdl_I32 (Val)); + when 8 => + Write_I64 (Res.Val.Mem, Ghdl_I64 (Val)); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Value_Discrete; + + function Create_Value_Uns (Val : Uns64; Vtype : Type_Acc) return Valtyp + is + Res : Valtyp; + begin + Res := Create_Value_Memory (Vtype); + case Vtype.Sz is + when 1 => + Write_U8 (Res.Val.Mem, Ghdl_U8 (Val)); + when 4 => + Write_U32 (Res.Val.Mem, Ghdl_U32 (Val)); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Value_Uns; + + function Create_Value_Int (Val : Int64; Vtype : Type_Acc) return Valtyp + is + Res : Valtyp; + begin + Res := Create_Value_Memory (Vtype); + case Vtype.Sz is + when 4 => + Write_I32 (Res.Val.Mem, Ghdl_I32 (Val)); + when 8 => + Write_I64 (Res.Val.Mem, Ghdl_I64 (Val)); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Value_Int; + + function Arr_Index (M : Memory_Ptr; Idx : Iir_Index32; El_Typ : Type_Acc) + return Memory_Ptr is + begin + return M + Size_Type (Idx) * El_Typ.Sz; + end Arr_Index; + + procedure Write_Value_Default (M : Memory_Ptr; Typ : Type_Acc) is + begin + case Typ.Kind is + when Type_Bit + | Type_Logic => + -- FIXME: what about subtype ? + Write_U8 (M, 0); + when Type_Discrete => + Write_Discrete (M, Typ, Typ.Drange.Left); + when Type_Float => + Write_Fp64 (M, Typ.Frange.Left); + when Type_Vector => + declare + Len : constant Iir_Index32 := Vec_Length (Typ); + El_Typ : constant Type_Acc := Typ.Vec_El; + begin + for I in 1 .. Len loop + Write_Value_Default (Arr_Index (M, I - 1, El_Typ), El_Typ); + end loop; + end; + when Type_Unbounded_Vector + | Type_Unbounded_Array + | Type_Unbounded_Record => + raise Internal_Error; + when Type_Slice => + raise Internal_Error; + when Type_Array => + declare + Len : constant Iir_Index32 := Get_Array_Flat_Length (Typ); + El_Typ : constant Type_Acc := Typ.Arr_El; + begin + for I in 1 .. Len loop + Write_Value_Default (Arr_Index (M, I - 1, El_Typ), El_Typ); + end loop; + end; + when Type_Record => + for I in Typ.Rec.E'Range loop + Write_Value_Default (M + Typ.Rec.E (I).Moff, Typ.Rec.E (I).Typ); + end loop; + when Type_Access => + Write_Access (M, Null_Heap_Index); + when Type_File + | Type_Protected => + raise Internal_Error; + end case; + end Write_Value_Default; + + function Create_Value_Default (Typ : Type_Acc) return Valtyp + is + Res : Valtyp; + begin + Res := Create_Value_Memory (Typ); + Write_Value_Default (Res.Val.Mem, Typ); + return Res; + end Create_Value_Default; + + function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc) + return Valtyp + is + Res : Valtyp; + begin + Res := Create_Value_Memory (Acc_Typ); + Write_Access (Res.Val.Mem, Val); + return Res; + end Create_Value_Access; + + function Value_To_String (Val : Valtyp) return String + is + Str : String (1 .. Natural (Val.Typ.Abounds.D (1).Len)); + begin + for I in Str'Range loop + Str (Natural (I)) := Character'Val + (Read_U8 (Val.Val.Mem + Size_Type (I - 1))); + end loop; + return Str; + end Value_To_String; + + function Get_Memtyp (V : Valtyp) return Memtyp is + begin + case V.Val.Kind is + when Value_Net + | Value_Wire + | Value_Signal => + raise Internal_Error; + when Value_Memory => + return (V.Typ, V.Val.Mem); + when Value_Alias => + declare + T : Memtyp; + begin + T := Get_Memtyp ((V.Typ, V.Val.A_Obj)); + return (T.Typ, T.Mem + V.Val.A_Off.Mem_Off); + end; + when Value_Const => + return Get_Memtyp ((V.Typ, V.Val.C_Val)); + when Value_File => + raise Internal_Error; + end case; + end Get_Memtyp; + + procedure Update_Index (Rng : Discrete_Range_Type; V : in out Valtyp) + is + T : Int64; + begin + T := Read_Discrete (V); + case Rng.Dir is + when Dir_To => + T := T + 1; + when Dir_Downto => + T := T - 1; + end case; + Write_Discrete (V, T); + end Update_Index; +end Elab.Vhdl_Values; diff --git a/src/synth/elab-vhdl_values.ads b/src/synth/elab-vhdl_values.ads new file mode 100644 index 000000000..047f294ba --- /dev/null +++ b/src/synth/elab-vhdl_values.ads @@ -0,0 +1,178 @@ +-- Values in 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 Ada.Unchecked_Deallocation; + +with Types; use Types; +with Areapools; use Areapools; + +with Grt.Files_Operations; + +with Vhdl.Nodes; use Vhdl.Nodes; + +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Memtype; use Elab.Memtype; + +package Elab.Vhdl_Values is + -- Values is how signals and variables are decomposed. This is similar to + -- values in simulation, but simplified (no need to handle files, + -- accesses...) + + type Value_Kind is + ( + -- Value is for a vector or a bit, and is the output of a gate. + Value_Net, + + -- Also a vector or a bit, but from an object. Has to be transformed + -- into a net. + Value_Wire, + + Value_Signal, + + -- Any kind of constant value, raw stored in memory. + Value_Memory, + + Value_File, + + -- A constant. This is a named value. One purpose is to avoid to + -- create many times the same net for the same value. + Value_Const, + + -- An alias. This is a reference to another value with a different + -- (but compatible) type. + Value_Alias + ); + + type Value_Type (Kind : Value_Kind); + + type Value_Acc is access Value_Type; + + type Heap_Index is new Uns32; + Null_Heap_Index : constant Heap_Index := 0; + + subtype File_Index is Grt.Files_Operations.Ghdl_File_Index; + + type Value_Type (Kind : Value_Kind) is record + case Kind is + when Value_Net + | Value_Wire => + N : Uns32; + when Value_Signal => + S : Uns32; + Init : Value_Acc; + when Value_Memory => + Mem : Memory_Ptr; + when Value_File => + File : File_Index; + when Value_Const => + C_Val : Value_Acc; + C_Loc : Node; + C_Net : Uns32; + when Value_Alias => + A_Obj : Value_Acc; + A_Typ : Type_Acc; -- The type of A_Obj. + A_Off : Value_Offsets; + end case; + end record; + + -- A tuple of type and value. + type Valtyp is record + Typ : Type_Acc; + Val : Value_Acc; + end record; + + No_Valtyp : constant Valtyp := (null, null); + + type Valtyp_Array is array (Nat32 range <>) of Valtyp; + type Valtyp_Array_Acc is access Valtyp_Array; + + procedure Free_Valtyp_Array is new Ada.Unchecked_Deallocation + (Valtyp_Array, Valtyp_Array_Acc); + + -- True if VAL is static, ie contains neither nets nor wires. + function Is_Static (Val : Value_Acc) return Boolean; + + function Is_Equal (L, R : Valtyp) return Boolean; + + function Create_Value_Memtyp (Mt : Memtyp) return Valtyp; + + -- Create a Value_Net. + function Create_Value_Net (S : Uns32) return Value_Acc; + + -- Create a Value_Wire. + function Create_Value_Wire (S : Uns32) return Value_Acc; + + function Create_Value_Signal (S : Uns32; Init : Value_Acc) return Value_Acc; + + function Create_Value_Memory (Vtype : Type_Acc) return Valtyp; + function Create_Value_Memory (Mt : Memtyp) return Valtyp; + + function Create_Value_Uns (Val : Uns64; Vtype : Type_Acc) return Valtyp; + function Create_Value_Int (Val : Int64; Vtype : Type_Acc) return Valtyp; + function Create_Value_Discrete (Val : Int64; Vtype : Type_Acc) + return Valtyp; + + function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc) + return Valtyp; + + function Create_Value_Float (Val : Fp64; Vtype : Type_Acc) return Valtyp; + + function Create_Value_File (Vtype : Type_Acc; File : File_Index) + return Valtyp; + + function Create_Value_Alias + (Obj : Valtyp; Off : Value_Offsets; Typ : Type_Acc) return Valtyp; + + function Create_Value_Const (Val : Valtyp; Loc : Node) return Valtyp; + + -- If VAL is a const, replace it by its value. + procedure Strip_Const (Vt : in out Valtyp); + + -- If VAL is a const or an alias, replace it by its value. + -- Used to extract the real data of a static value. Note that the type + -- is not correct anymore. + function Strip_Alias_Const (V : Valtyp) return Valtyp; + + -- Return the memtyp of V; also strip const and aliases. + function Get_Memtyp (V : Valtyp) return Memtyp; + + function Unshare (Src : Valtyp; Pool : Areapool_Acc) return Valtyp; + + -- Create a default initial value for TYP. + function Create_Value_Default (Typ : Type_Acc) return Valtyp; + procedure Write_Value_Default (M : Memory_Ptr; Typ : Type_Acc); + + -- Convert a value to a string. The value must be a const_array of scalar, + -- which represent characters. + function Value_To_String (Val : Valtyp) return String; + + -- Memory access. + procedure Write_Discrete (Vt : Valtyp; Val : Int64); + function Read_Discrete (Vt : Valtyp) return Int64; + + procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index); + function Read_Access (Mt : Memtyp) return Heap_Index; + function Read_Access (Vt : Valtyp) return Heap_Index; + + function Read_Fp64 (Vt : Valtyp) return Fp64; + + procedure Write_Value (Dest : Memory_Ptr; Vt : Valtyp); + + procedure Update_Index (Rng : Discrete_Range_Type; V : in out Valtyp); + +end Elab.Vhdl_Values; diff --git a/src/synth/elab.ads b/src/synth/elab.ads new file mode 100644 index 000000000..8d05336de --- /dev/null +++ b/src/synth/elab.ads @@ -0,0 +1,21 @@ +-- Elaboration root namespace. +-- Copyright (C) 2021 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 . + +package Elab is + pragma Pure; +end Elab; diff --git a/src/synth/synth-debugger.adb b/src/synth/synth-debugger.adb deleted file mode 100644 index 187412cc4..000000000 --- a/src/synth/synth-debugger.adb +++ /dev/null @@ -1,41 +0,0 @@ --- Debugging during synthesis (not enabled). --- Copyright (C) 2019 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; - -package body Synth.Debugger is - procedure Debug_Init (Top : Node) is - begin - null; - end Debug_Init; - - procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is - begin - raise Internal_Error; - end Debug_Break; - - procedure Debug_Leave (Inst : Synth_Instance_Acc) is - begin - raise Internal_Error; - end Debug_Leave; - - procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is - begin - null; - end Debug_Error; -end Synth.Debugger; diff --git a/src/synth/synth-debugger.ads b/src/synth/synth-debugger.ads deleted file mode 100644 index 329bab3e2..000000000 --- a/src/synth/synth-debugger.ads +++ /dev/null @@ -1,37 +0,0 @@ --- Debugging during synthesis. --- Copyright (C) 2019 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.Vhdl_Context; use Synth.Vhdl_Context; - -package Synth.Debugger is - -- If true, debugging is enabled: - -- * call Debug_Break() before executing the next sequential statement - -- * call Debug_Leave when a frame is destroyed. - Flag_Need_Debug : Boolean := False; - - procedure Debug_Init (Top : Node); - procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node); - - procedure Debug_Leave (Inst : Synth_Instance_Acc); - - -- To be called in case of execution error, like: - -- * index out of bounds. - procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node); -end Synth.Debugger; diff --git a/src/synth/synth-debugger__on.adb b/src/synth/synth-debugger__on.adb deleted file mode 100644 index d0e342e1e..000000000 --- a/src/synth/synth-debugger__on.adb +++ /dev/null @@ -1,1278 +0,0 @@ --- Debugging during synthesis. --- Copyright (C) 2019 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 System; - -with Types; use Types; -with Files_Map; -with Tables; -with Simple_IO; use Simple_IO; -with Utils_IO; use Utils_IO; -with Name_Table; -with Str_Table; -with Libraries; - -with Grt.Readline; - -with Vhdl.Errors; -with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk; -with Vhdl.Parse; -with Vhdl.Utils; use Vhdl.Utils; - -with Synth. Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; --- with Synth.Environment; use Synth.Environment; -with Synth.Flags; - -package body Synth.Debugger is - Current_Instance : Synth_Instance_Acc; - Current_Loc : Node; - - type Debug_Reason is - ( - Reason_Init, - Reason_Break, - Reason_Error - ); - - package Breakpoints is new Tables - (Table_Index_Type => Natural, - Table_Component_Type => Node, - Table_Low_Bound => 1, - Table_Initial => 16); - - function Is_Breakpoint_Hit return Boolean is - begin - for I in Breakpoints.First .. Breakpoints.Last loop - if Breakpoints.Table (I) = Current_Loc then - return True; - end if; - end loop; - return False; - end Is_Breakpoint_Hit; - - -- Current execution state, or reason to stop execution (set by the - -- last debugger command). - type Exec_State_Type is - (-- Execution should continue until a breakpoint is reached or assertion - -- failure. - Exec_Run, - - -- Execution will stop at the next statement. - Exec_Single_Step, - - -- Execution will stop at the next simple statement in the same frame. - Exec_Next, - - -- Execution will stop at the next statement in the same frame. In - -- case of compound statement, stop after the compound statement. - Exec_Next_Stmt); - - Exec_State : Exec_State_Type := Exec_Run; - - -- Current frame for next. - Exec_Instance : Synth_Instance_Acc; - - -- Current statement for next_stmt. - Exec_Statement : Node; - - function Is_Within_Statement (Stmt : Node; Cur : Node) return Boolean - is - Parent : Node; - begin - Parent := Cur; - loop - if Parent = Stmt then - return True; - end if; - case Get_Kind (Parent) is - when Iir_Kinds_Sequential_Statement => - Parent := Get_Parent (Parent); - when others => - return False; - end case; - end loop; - end Is_Within_Statement; - - Prompt_Debug : constant String := "debug> " & ASCII.NUL; - Prompt_Error : constant String := "error> " & ASCII.NUL; - Prompt_Init : constant String := "init> " & ASCII.NUL; - -- Prompt_Elab : constant String := "elab> " & ASCII.NUL; - - procedure Disp_Iir_Location (N : Node) is - begin - if N = Null_Iir then - Put_Err ("??:??:??"); - else - Put_Err (Vhdl.Errors.Disp_Location (N)); - end if; - Put_Err (": "); - end Disp_Iir_Location; - - -- For the list command: current file and current line. - List_Current_File : Source_File_Entry := No_Source_File_Entry; - List_Current_Line : Natural := 0; - List_Current_Line_Pos : Source_Ptr := 0; - - -- Set List_Current_* from a location. To be called after program break - -- to indicate current location. - procedure Set_List_Current (Loc : Location_Type) - is - Offset : Natural; - begin - Files_Map.Location_To_Coord - (Loc, List_Current_File, List_Current_Line_Pos, - List_Current_Line, Offset); - end Set_List_Current; - - procedure Disp_Current_Lines - is - use Files_Map; - -- Number of lines to display before and after the current line. - Radius : constant := 5; - - Buf : File_Buffer_Acc; - - Pos : Source_Ptr; - Line : Natural; - Len : Source_Ptr; - C : Character; - begin - if List_Current_Line > Radius then - Line := List_Current_Line - Radius; - else - Line := 1; - end if; - - Pos := File_Line_To_Position (List_Current_File, Line); - Buf := Get_File_Source (List_Current_File); - - while Line < List_Current_Line + Radius loop - -- Compute line length. - Len := 0; - loop - C := Buf (Pos + Len); - exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; - Len := Len + 1; - end loop; - - -- Disp line number. - declare - Str : constant String := Natural'Image (Line); - begin - if Line = List_Current_Line then - Put ('*'); - else - Put (' '); - end if; - Put ((Str'Length .. 5 => ' ')); - Put (Str (Str'First + 1 .. Str'Last)); - Put (' '); - end; - - -- Disp line. - Put_Line (String (Buf (Pos .. Pos + Len - 1))); - - -- Skip EOL. - exit when C = ASCII.EOT; - Pos := Pos + Len + 1; - if C = ASCII.CR then - if Buf (Pos) = ASCII.LF then - Pos := Pos + 1; - end if; - else - pragma Assert (C = ASCII.LF); - if Buf (Pos) = ASCII.CR then - Pos := Pos + 1; - end if; - end if; - - Line := Line + 1; - end loop; - end Disp_Current_Lines; - - procedure Disp_Source_Line (Loc : Location_Type) - is - use Files_Map; - - File : Source_File_Entry; - Line_Pos : Source_Ptr; - Line : Natural; - Offset : Natural; - Buf : File_Buffer_Acc; - Next_Line_Pos : Source_Ptr; - begin - Location_To_Coord (Loc, File, Line_Pos, Line, Offset); - Buf := Get_File_Source (File); - Next_Line_Pos := File_Line_To_Position (File, Line + 1); - Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); - end Disp_Source_Line; - - -- The status of the debugger. This status can be modified by a command - -- as a side effect to resume or quit the debugger. - type Command_Status_Type is (Status_Default, Status_Quit); - Command_Status : Command_Status_Type; - - -- This exception can be raised by a debugger command to directly return - -- to the prompt. - Command_Error : exception; - - type Menu_Procedure is access procedure (Line : String); - - -- If set (by commands), call this procedure on empty line to repeat - -- last command. - Cmd_Repeat : Menu_Procedure; - - type Menu_Kind is (Menu_Command, Menu_Submenu); - type Menu_Entry (Kind : Menu_Kind); - type Menu_Entry_Acc is access all Menu_Entry; - - type Cst_String_Acc is access constant String; - - type Menu_Entry (Kind : Menu_Kind) is record - Name : Cst_String_Acc; - Next : Menu_Entry_Acc; - - case Kind is - when Menu_Command => - Proc : Menu_Procedure; - when Menu_Submenu => - First, Last : Menu_Entry_Acc := null; - end case; - end record; - - function Is_Blank (C : Character) return Boolean is - begin - return C = ' ' or else C = ASCII.HT; - end Is_Blank; - - function Skip_Blanks (S : String) return Positive - is - P : Positive := S'First; - begin - while P <= S'Last and then Is_Blank (S (P)) loop - P := P + 1; - end loop; - return P; - end Skip_Blanks; - - -- Return the position of the last character of the word (the last - -- non-blank character). - function Get_Word (S : String) return Positive - is - P : Positive := S'First; - begin - while P <= S'Last and then not Is_Blank (S (P)) loop - P := P + 1; - end loop; - return P - 1; - end Get_Word; - - procedure Disp_Memtyp (M : Memtyp; Vtype : Node); - - procedure Disp_Discrete_Value (Val : Int64; Btype : Node) is - begin - case Get_Kind (Btype) is - when Iir_Kind_Integer_Type_Definition => - Put_Int64 (Val); - when Iir_Kind_Enumeration_Type_Definition => - declare - Pos : constant Natural := Natural (Val); - Enums : constant Node_Flist := - Get_Enumeration_Literal_List (Btype); - Id : constant Name_Id := - Get_Identifier (Get_Nth_Element (Enums, Pos)); - begin - Put (Name_Table.Image (Id)); - end; - when others => - Vhdl.Errors.Error_Kind ("disp_discrete_value", Btype); - end case; - end Disp_Discrete_Value; - - procedure Disp_Value_Vector (Mem : Memtyp; A_Type: Node; Bound : Bound_Type) - is - El_Type : constant Node := Get_Base_Type (Get_Element_Subtype (A_Type)); - El_Typ : constant Type_Acc := Get_Array_Element (Mem.Typ); - type Last_Enum_Type is (None, Char, Identifier); - Last_Enum : Last_Enum_Type; - Enum_List : Node_Flist; - El_Id : Name_Id; - El_Pos : Natural; - begin - -- Pretty print vectors of enumerated types - if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition then - Last_Enum := None; - Enum_List := Get_Enumeration_Literal_List (El_Type); - for I in 1 .. Bound.Len loop - El_Pos := Natural - (Read_Discrete - (Memtyp'(El_Typ, Mem.Mem + Size_Type (I - 1) * El_Typ.Sz))); - El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); - if Name_Table.Is_Character (El_Id) then - case Last_Enum is - when None => - Put (""""); - when Identifier => - Put (" & """); - when Char => - null; - end case; - Put (Name_Table.Get_Character (El_Id)); - Last_Enum := Char; - else - case Last_Enum is - when None => - null; - when Identifier => - Put (" & "); - when Char => - Put (""" & "); - end case; - Put (Name_Table.Image (El_Id)); - Last_Enum := Identifier; - end if; - end loop; - case Last_Enum is - when None => - Put (""""""); -- Simply "" - when Identifier => - null; - when Char => - Put (""""); - end case; - else - Put ("("); - for I in 1 .. Bound.Len loop - if I /= 1 then - Put (", "); - end if; - Disp_Memtyp ((El_Typ, Mem.Mem + Size_Type (I - 1) * Mem.Typ.Sz), - El_Type); - end loop; - Put (")"); - end if; - end Disp_Value_Vector; - - procedure Disp_Value_Array (Mem : Memtyp; A_Type: Node; Dim: Dim_Type) - is - Stride : Size_Type; - begin - if Dim = Mem.Typ.Abounds.Ndim then - -- Last dimension - Disp_Value_Vector (Mem, A_Type, Mem.Typ.Abounds.D (Dim)); - else - Stride := Mem.Typ.Arr_El.Sz; - for I in Dim + 1 .. Mem.Typ.Abounds.Ndim loop - Stride := Stride * Size_Type (Mem.Typ.Abounds.D (I).Len); - end loop; - - Put ("("); - for I in 1 .. Mem.Typ.Abounds.D (Dim).Len loop - if I /= 1 then - Put (", "); - end if; - Disp_Value_Array ((Mem.Typ, Mem.Mem + Stride), A_Type, Dim + 1); - end loop; - Put (")"); - end if; - end Disp_Value_Array; - - procedure Disp_Memtyp (M : Memtyp; Vtype : Node) is - begin - if M.Mem = null then - Put ("*NULL*"); - return; - end if; - - case M.Typ.Kind is - when Type_Discrete - | Type_Bit - | Type_Logic => - Disp_Discrete_Value (Read_Discrete (M), Get_Base_Type (Vtype)); - when Type_Vector => - Disp_Value_Vector (M, Vtype, M.Typ.Vbound); - when Type_Array => - Disp_Value_Array (M, Vtype, 1); - when Type_Float => - Put ("*float*"); - when Type_Slice => - Put ("*slice*"); - when Type_File => - Put ("*file*"); - when Type_Record => - Put ("*record*"); - when Type_Access => - Put ("*access*"); - when Type_Protected => - Put ("*protected*"); - when Type_Unbounded_Array - | Type_Unbounded_Record - | Type_Unbounded_Vector => - Put ("*unbounded*"); - end case; - end Disp_Memtyp; - - procedure Disp_Value (Vt : Valtyp; Vtype : Node) is - begin - if Vt.Val = null then - Put ("*NULL*"); - return; - end if; - - case Vt.Val.Kind is - when Value_Net => - Put ("net"); - when Value_Wire => - Put ("wire"); - when Value_File => - Put ("file"); - when Value_Const => - Put ("const: "); - Disp_Memtyp (Get_Memtyp (Vt), Vtype); - when Value_Alias => - Put ("alias"); - Disp_Memtyp (Get_Memtyp (Vt), Vtype); - when Value_Memory => - Disp_Memtyp (Get_Memtyp (Vt), Vtype); - end case; - end Disp_Value; - - procedure Disp_Bound_Type (Bound : Bound_Type) is - begin - Put_Int32 (Bound.Left); - Put (' '); - case Bound.Dir is - when Dir_To => - Put ("to"); - when Dir_Downto => - Put ("downto"); - end case; - Put (' '); - Put_Int32 (Bound.Right); - end Disp_Bound_Type; - - procedure Disp_Type (Typ : Type_Acc; Vtype : Node) - is - pragma Unreferenced (Vtype); - begin - case Typ.Kind is - when Type_Bit => - Put ("bit"); - when Type_Logic => - Put ("logic"); - when Type_Discrete => - Put ("discrete"); - when Type_Float => - Put ("float"); - when Type_Vector => - Put ("vector ("); - Disp_Bound_Type (Typ.Vbound); - Put (')'); - when Type_Unbounded_Vector => - Put ("unbounded_vector"); - when Type_Array => - Put ("array"); - when Type_Unbounded_Array => - Put ("unbounded_array"); - when Type_Unbounded_Record => - Put ("unbounded_record"); - when Type_Record => - Put ("record"); - when Type_Slice => - Put ("slice"); - when Type_Access => - Put ("access"); - when Type_File => - Put ("file"); - when Type_Protected => - Put ("protected"); - end case; - end Disp_Type; - - procedure Disp_Declaration_Object - (Instance : Synth_Instance_Acc; Decl : Iir) is - begin - case Get_Kind (Decl) is - when Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_File_Declaration => - declare - Val : constant Valtyp := Get_Value (Instance, Decl); - Dtype : constant Node := Get_Type (Decl); - begin - Put (Vhdl.Errors.Disp_Node (Decl)); - Put (": "); - Disp_Type (Val.Typ, Dtype); - Put (" = "); - Disp_Value (Val, Dtype); - New_Line; - end; - when Iir_Kinds_Signal_Attribute => - -- FIXME: todo ? - null; - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration - | Iir_Kind_Subtype_Declaration => - -- FIXME: disp ranges - null; - when Iir_Kind_Function_Declaration - | Iir_Kind_Function_Body - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Procedure_Body => - null; - when others => - Vhdl.Errors.Error_Kind ("disp_declaration_object", Decl); - end case; - end Disp_Declaration_Object; - - procedure Disp_Declaration_Objects - (Instance : Synth_Instance_Acc; Decl_Chain : Iir) - is - El : Iir; - begin - El := Decl_Chain; - while El /= Null_Iir loop - Disp_Declaration_Object (Instance, El); - El := Get_Chain (El); - end loop; - end Disp_Declaration_Objects; - - procedure Info_Params_Proc (Line : String) - is - pragma Unreferenced (Line); - Decl : Iir; - Params : Iir; - begin - Decl := Get_Source_Scope (Current_Instance); - loop - case Get_Kind (Decl) is - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - Decl := Get_Subprogram_Specification (Decl); - exit; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Put_Line ("processes have no parameters"); - return; - when Iir_Kind_While_Loop_Statement - | Iir_Kind_If_Statement - | Iir_Kind_For_Loop_Statement - | Iir_Kind_Case_Statement => - Decl := Get_Parent (Decl); - when others => - Vhdl.Errors.Error_Kind ("info_params_proc", Decl); - end case; - end loop; - Params := Get_Interface_Declaration_Chain (Decl); - Disp_Declaration_Objects (Current_Instance, Params); - end Info_Params_Proc; - - procedure Info_Locals_Proc (Line : String) - is - pragma Unreferenced (Line); - Decl : Iir; - Decls : Iir; - begin - -- From statement to declaration. - Decl := Get_Source_Scope (Current_Instance); - loop - case Get_Kind (Decl) is - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - Decls := Get_Declaration_Chain (Decl); - exit; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Put_Line ("processes have no parameters"); - return; - when Iir_Kind_While_Loop_Statement - | Iir_Kind_If_Statement - | Iir_Kind_For_Loop_Statement - | Iir_Kind_Case_Statement => - Decl := Get_Parent (Decl); - when others => - Vhdl.Errors.Error_Kind ("info_params_proc", Decl); - end case; - end loop; - Disp_Declaration_Objects (Current_Instance, Decls); - end Info_Locals_Proc; - - function Walk_Files (Cb : Walk_Cb) return Walk_Status - is - Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; - File : Iir_Design_File; - begin - while Lib /= Null_Iir loop - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - case Cb.all (File) is - when Walk_Continue => - null; - when Walk_Up => - exit; - when Walk_Abort => - return Walk_Abort; - end case; - File := Get_Chain (File); - end loop; - Lib := Get_Chain (Lib); - end loop; - return Walk_Continue; - end Walk_Files; - - Walk_Units_Cb : Walk_Cb; - - function Cb_Walk_Units (Design_File : Iir) return Walk_Status - is - Unit : Iir_Design_Unit; - begin - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is - when Walk_Continue => - null; - when Walk_Abort => - return Walk_Abort; - when Walk_Up => - exit; - end case; - Unit := Get_Chain (Unit); - end loop; - return Walk_Continue; - end Cb_Walk_Units; - - function Walk_Units (Cb : Walk_Cb) return Walk_Status is - begin - Walk_Units_Cb := Cb; - return Walk_Files (Cb_Walk_Units'Access); - end Walk_Units; - - Walk_Declarations_Cb : Walk_Cb; - - function Cb_Walk_Declarations (Unit : Iir) return Walk_Status - is - function Walk_Decl_Chain (Chain : Iir) return Walk_Status - is - Decl : Iir; - begin - Decl := Chain; - while Decl /= Null_Iir loop - case Walk_Declarations_Cb.all (Decl) is - when Walk_Abort => - return Walk_Abort; - when Walk_Up => - return Walk_Continue; - when Walk_Continue => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - return Walk_Continue; - end Walk_Decl_Chain; - - function Walk_Conc_Chain (Chain : Iir) return Walk_Status; - - function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is - begin - if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then - return Walk_Abort; - end if; - if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort - then - return Walk_Abort; - end if; - return Walk_Continue; - end Walk_Generate_Statement_Body; - - function Walk_Conc_Chain (Chain : Iir) return Walk_Status - is - Stmt : Iir := Chain; - begin - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kinds_Process_Statement => - if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) - = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_For_Generate_Statement => - if Walk_Declarations_Cb.all - (Get_Parameter_Specification (Stmt)) = Walk_Abort - or else Walk_Generate_Statement_Body - (Get_Generate_Statement_Body (Stmt)) = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_If_Generate_Statement => - declare - Stmt1 : Iir; - begin - Stmt1 := Stmt; - while Stmt1 /= Null_Iir loop - if Walk_Generate_Statement_Body - (Get_Generate_Statement_Body (Stmt)) = Walk_Abort - then - return Walk_Abort; - end if; - Stmt1 := Get_Generate_Else_Clause (Stmt1); - end loop; - end; - when Iir_Kind_Component_Instantiation_Statement - | Iir_Kind_Concurrent_Simple_Signal_Assignment => - null; - when Iir_Kind_Block_Statement => - -- FIXME: header - if (Walk_Decl_Chain - (Get_Declaration_Chain (Stmt)) = Walk_Abort) - or else - (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) - then - return Walk_Abort; - end if; - when others => - Vhdl.Errors.Error_Kind ("walk_conc_chain", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - return Walk_Continue; - end Walk_Conc_Chain; - begin - case Get_Kind (Unit) is - when Iir_Kind_Entity_Declaration => - if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort - or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort - or else (Walk_Decl_Chain - (Get_Declaration_Chain (Unit)) = Walk_Abort) - or else (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) - then - return Walk_Abort; - end if; - when Iir_Kind_Architecture_Body => - if (Walk_Decl_Chain - (Get_Declaration_Chain (Unit)) = Walk_Abort) - or else (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) - then - return Walk_Abort; - end if; - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => - if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_Configuration_Declaration => - if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort - then - return Walk_Abort; - end if; - -- FIXME: block configuration ? - when Iir_Kind_Context_Declaration => - null; - when others => - Vhdl.Errors.Error_Kind ("Cb_Walk_Declarations", Unit); - end case; - return Walk_Continue; - end Cb_Walk_Declarations; - - function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is - begin - Walk_Declarations_Cb := Cb; - return Walk_Units (Cb_Walk_Declarations'Access); - end Walk_Declarations; - - -- Next statement in the same frame, but handle compound statements as - -- one statement. - procedure Next_Stmt_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next_Stmt; - Exec_Instance := Current_Instance; - Exec_Statement := Current_Loc; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - end Next_Stmt_Proc; - - -- Finish parent statement. - procedure Finish_Stmt_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next_Stmt; - Exec_Instance := Current_Instance; - Exec_Statement := Get_Parent (Current_Loc); - Flag_Need_Debug := True; - Command_Status := Status_Quit; - end Finish_Stmt_Proc; - - procedure Next_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next; - Exec_Instance := Current_Instance; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - Cmd_Repeat := Next_Proc'Access; - end Next_Proc; - - procedure Step_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Single_Step; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - Cmd_Repeat := Step_Proc'Access; - end Step_Proc; - - Break_Id : Name_Id; - - procedure Set_Breakpoint (Stmt : Iir) is - begin - Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); - Breakpoints.Append (Stmt); - Flag_Need_Debug := True; - end Set_Breakpoint; - - function Cb_Set_Break (El : Iir) return Walk_Status is - begin - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Get_Identifier (El) = Break_Id - and then - Get_Implicit_Definition (El) not in Iir_Predefined_Implicit - then - Set_Breakpoint - (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); - end if; - when others => - null; - end case; - return Walk_Continue; - end Cb_Set_Break; - - procedure Break_Proc (Line : String) - is - Status : Walk_Status; - P : Natural; - begin - P := Skip_Blanks (Line); - if Line (P) = '"' then - -- An operator name. - declare - use Str_Table; - Str : String8_Id; - Len : Nat32; - begin - Str := Create_String8; - Len := 0; - P := P + 1; - while Line (P) /= '"' loop - Append_String8_Char (Line (P)); - Len := Len + 1; - P := P + 1; - end loop; - Break_Id := Vhdl.Parse.Str_To_Operator_Name - (Str, Len, No_Location); - -- FIXME: free string. - -- FIXME: catch error. - end; - else - Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); - end if; - Status := Walk_Declarations (Cb_Set_Break'Access); - pragma Assert (Status = Walk_Continue); - end Break_Proc; - - procedure Help_Proc (Line : String); - - procedure Prepare_Continue is - begin - Command_Status := Status_Quit; - - -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. - Flag_Need_Debug := False; - for I in Breakpoints.First .. Breakpoints.Last loop - Flag_Need_Debug := True; - exit; - end loop; - end Prepare_Continue; - - procedure Cont_Proc (Line : String) is - pragma Unreferenced (Line); - begin - Prepare_Continue; - end Cont_Proc; - - procedure List_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Disp_Current_Lines; - end List_Proc; - - Menu_Info_Locals : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("locals"), - Next => null, -- Menu_Info_Tree'Access, - Proc => Info_Locals_Proc'Access); - - Menu_Info_Params : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("param*eters"), - Next => Menu_Info_Locals'Access, -- Menu_Info_Tree'Access, - Proc => Info_Params_Proc'Access); - - Menu_Info : aliased Menu_Entry := - (Kind => Menu_Submenu, - Name => new String'("i*nfo"), - Next => null, -- Menu_Ps'Access, - First | Last => Menu_Info_Params'Access); -- Menu_Info_Proc'Access); - - Menu_List : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("l*list"), - Next => Menu_Info'Access, -- null, - Proc => List_Proc'Access); - - Menu_Cont : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("c*ont"), - Next => Menu_List'Access, --Menu_Print'Access, - Proc => Cont_Proc'Access); - - Menu_Nstmt : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("ns*tmt"), - Next => Menu_Cont'Access, -- Menu_Up'Access, - Proc => Next_Stmt_Proc'Access); - - Menu_Fstmt : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("fs*tmt"), - Next => Menu_Nstmt'Access, - Proc => Finish_Stmt_Proc'Access); - - Menu_Next : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("n*ext"), - Next => Menu_Fstmt'Access, - Proc => Next_Proc'Access); - - Menu_Step : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("s*tep"), - Next => Menu_Next'Access, - Proc => Step_Proc'Access); - - Menu_Break : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("b*reak"), - Next => Menu_Step'Access, - Proc => Break_Proc'Access); - - Menu_Help2 : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("?"), - Next => Menu_Break'Access, -- Menu_Help1'Access, - Proc => Help_Proc'Access); - - Menu_Top : aliased Menu_Entry := - (Kind => Menu_Submenu, - Name => null, - Next => null, - First | Last => Menu_Help2'Access); - - - function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) - return Menu_Entry_Acc - is - function Is_Cmd (Cmd_Name : String; Str : String) return Boolean - is - -- Number of characters that were compared. - P : Natural; - begin - P := 0; - -- Prefix (before the '*'). - loop - if P = Cmd_Name'Length then - -- Full match. - return P = Str'Length; - end if; - exit when Cmd_Name (Cmd_Name'First + P) = '*'; - if P = Str'Length then - -- Command is too short - return False; - end if; - if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then - return False; - end if; - P := P + 1; - end loop; - -- Suffix (after the '*') - loop - if P = Str'Length then - return True; - end if; - if P + 1 = Cmd_Name'Length then - -- String is too long - return False; - end if; - if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then - return False; - end if; - P := P + 1; - end loop; - end Is_Cmd; - Ent : Menu_Entry_Acc; - begin - Ent := Menu.First; - while Ent /= null loop - if Is_Cmd (Ent.Name.all, Cmd) then - return Ent; - end if; - Ent := Ent.Next; - end loop; - return null; - end Find_Menu; - - procedure Parse_Command (Line : String; - P : in out Natural; - Menu : out Menu_Entry_Acc) - is - E : Natural; - begin - P := Skip_Blanks (Line (P .. Line'Last)); - if P > Line'Last then - return; - end if; - E := Get_Word (Line (P .. Line'Last)); - Menu := Find_Menu (Menu, Line (P .. E)); - if Menu = null then - Put_Line ("command '" & Line (P .. E) & "' not found"); - end if; - P := E + 1; - end Parse_Command; - - procedure Help_Proc (Line : String) - is - P : Natural; - Root : Menu_Entry_Acc := Menu_Top'access; - begin - Put_Line ("This is the help command"); - P := Line'First; - while P < Line'Last loop - Parse_Command (Line, P, Root); - if Root = null then - return; - elsif Root.Kind /= Menu_Submenu then - Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); - return; - end if; - end loop; - - Root := Root.First; - while Root /= null loop - Put (Root.Name.all); - if Root.Kind = Menu_Submenu then - Put (" (menu)"); - end if; - New_Line; - Root := Root.Next; - end loop; - end Help_Proc; - - procedure Debug (Reason: Debug_Reason) - is - use Grt.Readline; - Raw_Line : Char_Ptr; - Prompt : System.Address; - begin - Prompt := Prompt_Debug'Address; - - case Reason is - when Reason_Init => - Prompt := Prompt_Init'Address; - when Reason_Error => - Prompt := Prompt_Error'Address; - when Reason_Break => - case Exec_State is - when Exec_Run => - if not Is_Breakpoint_Hit then - return; - end if; - Put_Line ("breakpoint hit"); - when Exec_Single_Step => - null; - when Exec_Next => - if Current_Instance /= Exec_Instance then - return; - end if; - when Exec_Next_Stmt => - if Current_Instance /= Exec_Instance - or else Is_Within_Statement (Exec_Statement, Current_Loc) - then - return; - end if; - end case; - -- Default state. - Exec_State := Exec_Run; - - end case; - - case Reason is - when Reason_Error - | Reason_Break => - Put ("stopped at: "); - Disp_Iir_Location (Current_Loc); - New_Line; - Disp_Source_Line (Get_Location (Current_Loc)); - when others => - null; - end case; - - if Current_Loc /= Null_Node then - Set_List_Current (Get_Location (Current_Loc)); - end if; - - Command_Status := Status_Default; - - loop - loop - Raw_Line := Readline (Prompt); - -- Skip empty lines - if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then - if Cmd_Repeat /= null then - Cmd_Repeat.all (""); - case Command_Status is - when Status_Default => - null; - when Status_Quit => - return; - end case; - end if; - else - Cmd_Repeat := null; - exit; - end if; - end loop; - declare - Line_Last : constant Natural := Strlen (Raw_Line); - Line : String renames Raw_Line (1 .. Line_Last); - P, E : Positive; - Cmd : Menu_Entry_Acc := Menu_Top'Access; - begin - -- Find command - P := 1; - loop - E := P; - Parse_Command (Line, E, Cmd); - exit when Cmd = null; - case Cmd.Kind is - when Menu_Submenu => - if E > Line_Last then - Put_Line ("missing command for submenu " - & Line (P .. E - 1)); - Cmd := null; - exit; - end if; - P := E; - when Menu_Command => - exit; - end case; - end loop; - - if Cmd /= null then - Cmd.Proc.all (Line (E .. Line_Last)); - - case Command_Status is - when Status_Default => - null; - when Status_Quit => - exit; - end case; - end if; - exception - when Command_Error => - null; - end; - end loop; - -- Put ("resuming"); - end Debug; - - procedure Debug_Init (Top : Node) is - begin - Current_Instance := null; - Current_Loc := Top; - - -- To avoid warnings. - Exec_Statement := Null_Node; - Exec_Instance := null; - - Debug (Reason_Init); - end Debug_Init; - - procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is - begin - Current_Instance := Inst; - Current_Loc := Stmt; - - Debug (Reason_Break); - end Debug_Break; - - procedure Debug_Leave (Inst : Synth_Instance_Acc) is - begin - if Exec_Instance = Inst then - -- Will be destroyed. - Exec_Instance := null; - - case Exec_State is - when Exec_Run => - null; - when Exec_Single_Step => - null; - when Exec_Next - | Exec_Next_Stmt => - -- Leave the frame, will stop just after. - Exec_State := Exec_Single_Step; - end case; - end if; - end Debug_Leave; - - procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is - begin - if Flags.Flag_Debug_Enable then - Current_Instance := Inst; - Current_Loc := Expr; - Debug (Reason_Error); - end if; - end Debug_Error; -end Synth.Debugger; diff --git a/src/synth/synth-disp_vhdl.adb b/src/synth/synth-disp_vhdl.adb index c920e0ae5..bc1642c07 100644 --- a/src/synth/synth-disp_vhdl.adb +++ b/src/synth/synth-disp_vhdl.adb @@ -27,11 +27,11 @@ with Vhdl.Ieee.Std_Logic_1164; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; + with Netlists.Iterators; use Netlists.Iterators; with Netlists.Disp_Vhdl; use Netlists.Disp_Vhdl; -with Synth.Objtypes; use Synth.Objtypes; - package body Synth.Disp_Vhdl is procedure Disp_Signal (Desc : Port_Desc) is begin diff --git a/src/synth/synth-disp_vhdl.ads b/src/synth/synth-disp_vhdl.ads index 39706a085..0bfac8068 100644 --- a/src/synth/synth-disp_vhdl.ads +++ b/src/synth/synth-disp_vhdl.ads @@ -17,8 +17,8 @@ -- along with this program. If not, see . with Netlists; use Netlists; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; with Vhdl.Nodes; use Vhdl.Nodes; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; package Synth.Disp_Vhdl is -- Disp ENT (like the original text) and its content as a wrapper. diff --git a/src/synth/synth-ieee-numeric_std.adb b/src/synth/synth-ieee-numeric_std.adb index fd260a59b..0697a7697 100644 --- a/src/synth/synth-ieee-numeric_std.adb +++ b/src/synth/synth-ieee-numeric_std.adb @@ -18,7 +18,8 @@ with Types_Utils; use Types_Utils; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; + with Synth.Errors; use Synth.Errors; with Synth.Ieee.Std_Logic_1164; use Synth.Ieee.Std_Logic_1164; diff --git a/src/synth/synth-ieee-numeric_std.ads b/src/synth/synth-ieee-numeric_std.ads index bad079b76..b3bc9a632 100644 --- a/src/synth/synth-ieee-numeric_std.ads +++ b/src/synth/synth-ieee-numeric_std.ads @@ -18,7 +18,7 @@ with Types; use Types; -with Synth.Objtypes; use Synth.Objtypes; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; with Synth.Source; use Synth.Source; package Synth.Ieee.Numeric_Std is diff --git a/src/synth/synth-ieee-std_logic_1164.ads b/src/synth/synth-ieee-std_logic_1164.ads index c3670882f..33a298f81 100644 --- a/src/synth/synth-ieee-std_logic_1164.ads +++ b/src/synth/synth-ieee-std_logic_1164.ads @@ -18,7 +18,7 @@ with Types; use Types; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; package Synth.Ieee.Std_Logic_1164 is diff --git a/src/synth/synth-memtype.adb b/src/synth/synth-memtype.adb deleted file mode 100644 index 7c8943abd..000000000 --- a/src/synth/synth-memtype.adb +++ /dev/null @@ -1,117 +0,0 @@ --- Values in 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 System; use System; -with System.Storage_Elements; - -package body Synth.Memtype is - - function "+" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr - is - use System.Storage_Elements; - begin - return To_Memory_Ptr (To_Address (Base) + Storage_Offset (Off)); - end "+"; - - type Ghdl_U8_Ptr is access all Ghdl_U8; - function To_U8_Ptr is - new Ada.Unchecked_Conversion (Address, Ghdl_U8_Ptr); - - procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8) is - begin - To_U8_Ptr (To_Address (Mem)).all := Val; - end Write_U8; - - function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8 is - begin - return To_U8_Ptr (To_Address (Mem)).all; - end Read_U8; - - procedure Write_I32 (Mem : Memory_Ptr; Val : Ghdl_I32) - is - V : Ghdl_I32; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - V := Val; - end Write_I32; - - function Read_I32 (Mem : Memory_Ptr) return Ghdl_I32 - is - V : Ghdl_I32; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - return V; - end Read_I32; - - procedure Write_U32 (Mem : Memory_Ptr; Val : Ghdl_U32) - is - V : Ghdl_U32; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - V := Val; - end Write_U32; - - function Read_U32 (Mem : Memory_Ptr) return Ghdl_U32 - is - V : Ghdl_U32; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - return V; - end Read_U32; - - procedure Write_I64 (Mem : Memory_Ptr; Val : Ghdl_I64) - is - V : Ghdl_I64; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - V := Val; - end Write_I64; - - function Read_I64 (Mem : Memory_Ptr) return Ghdl_I64 - is - V : Ghdl_I64; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - return V; - end Read_I64; - - procedure Write_Fp64 (Mem : Memory_Ptr; Val : Fp64) - is - V : Fp64; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - V := Val; - end Write_Fp64; - - function Read_Fp64 (Mem : Memory_Ptr) return Fp64 - is - V : Fp64; - for V'Address use To_Address (Mem); - pragma Import (Ada, V); - begin - return V; - end Read_Fp64; - -end Synth.Memtype; diff --git a/src/synth/synth-memtype.ads b/src/synth/synth-memtype.ads deleted file mode 100644 index ee6f61c38..000000000 --- a/src/synth/synth-memtype.ads +++ /dev/null @@ -1,58 +0,0 @@ --- Values in 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 System; -with Ada.Unchecked_Conversion; - -with Types; use Types; - -with Grt.Types; use Grt.Types; - -package Synth.Memtype is - type Memory_Element is mod 2**8; - type Memory_Array is array (Size_Type range <>) of Memory_Element; - - -- Thin pointer for a generic pointer. - type Memory_Ptr is access all Memory_Array (Size_Type); - pragma No_Strict_Aliasing (Memory_Ptr); - - -- For conversions use Address to avoid compiler warnings about alignment. - function To_Address is new Ada.Unchecked_Conversion - (Memory_Ptr, System.Address); - function To_Memory_Ptr is new Ada.Unchecked_Conversion - (System.Address, Memory_Ptr); - - -- Low-level functions. - - function "+" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr; - - procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8); - function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8; - - procedure Write_U32 (Mem : Memory_Ptr; Val : Ghdl_U32); - function Read_U32 (Mem : Memory_Ptr) return Ghdl_U32; - - procedure Write_I32 (Mem : Memory_Ptr; Val : Ghdl_I32); - function Read_I32 (Mem : Memory_Ptr) return Ghdl_I32; - - procedure Write_I64 (Mem : Memory_Ptr; Val : Ghdl_I64); - function Read_I64 (Mem : Memory_Ptr) return Ghdl_I64; - - procedure Write_Fp64 (Mem : Memory_Ptr; Val : Fp64); - function Read_Fp64 (Mem : Memory_Ptr) return Fp64; -end Synth.Memtype; diff --git a/src/synth/synth-objtypes.adb b/src/synth/synth-objtypes.adb deleted file mode 100644 index 036c4151d..000000000 --- a/src/synth/synth-objtypes.adb +++ /dev/null @@ -1,776 +0,0 @@ --- Values in 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 Ada.Unchecked_Conversion; -with System; use System; - -with Mutils; use Mutils; - -package body Synth.Objtypes is - function To_Bound_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Bound_Array_Acc); - - function To_Rec_El_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Rec_El_Array_Acc); - - function To_Type_Acc is new Ada.Unchecked_Conversion - (System.Address, Type_Acc); - - function "+" (L, R : Value_Offsets) return Value_Offsets is - begin - return (L.Net_Off + R.Net_Off, L.Mem_Off + R.Mem_Off); - end "+"; - - function Is_Bounded_Type (Typ : Type_Acc) return Boolean is - begin - case Typ.Kind is - when Type_Bit - | Type_Logic - | Type_Discrete - | Type_Float - | Type_Vector - | Type_Slice - | Type_Array - | Type_Record - | Type_Access - | Type_File => - return True; - when Type_Unbounded_Array - | Type_Unbounded_Vector - | Type_Unbounded_Record - | Type_Protected => - return False; - end case; - end Is_Bounded_Type; - - function Are_Types_Equal (L, R : Type_Acc) return Boolean is - begin - if L.Kind /= R.Kind - or else L.W /= R.W - then - return False; - end if; - if L = R then - return True; - end if; - - case L.Kind is - when Type_Bit - | Type_Logic => - return True; - when Type_Discrete => - return L.Drange = R.Drange; - when Type_Float => - return L.Frange = R.Frange; - when Type_Vector => - return L.Vbound = R.Vbound - and then Are_Types_Equal (L.Vec_El, R.Vec_El); - when Type_Unbounded_Vector => - return Are_Types_Equal (L.Uvec_El, R.Uvec_El); - when Type_Slice => - return Are_Types_Equal (L.Slice_El, R.Slice_El); - when Type_Array => - if L.Abounds.Ndim /= R.Abounds.Ndim then - return False; - end if; - for I in L.Abounds.D'Range loop - if L.Abounds.D (I) /= R.Abounds.D (I) then - return False; - end if; - end loop; - return Are_Types_Equal (L.Arr_El, R.Arr_El); - when Type_Unbounded_Array => - return L.Uarr_Ndim = R.Uarr_Ndim - and then Are_Types_Equal (L.Uarr_El, R.Uarr_El); - when Type_Record - | Type_Unbounded_Record => - if L.Rec.Len /= R.Rec.Len then - return False; - end if; - for I in L.Rec.E'Range loop - if not Are_Types_Equal (L.Rec.E (I).Typ, R.Rec.E (I).Typ) then - return False; - end if; - end loop; - return True; - when Type_Access => - return Are_Types_Equal (L.Acc_Acc, R.Acc_Acc); - when Type_File => - return Are_Types_Equal (L.File_Typ, R.File_Typ); - when Type_Protected => - return False; - end case; - end Are_Types_Equal; - - function Discrete_Range_Width (Rng : Discrete_Range_Type) return Width - is - Lo, Hi : Int64; - W : Width; - begin - case Rng.Dir is - when Dir_To => - Lo := Rng.Left; - Hi := Rng.Right; - when Dir_Downto => - Lo := Rng.Right; - Hi := Rng.Left; - end case; - if Lo > Hi then - -- Null range. - W := 0; - elsif Lo >= 0 then - -- Positive. - W := Width (Clog2 (Uns64 (Hi) + 1)); - elsif Lo = Int64'First then - -- Handle possible overflow. - W := 64; - elsif Hi < 0 then - -- Negative only. - W := Width (Clog2 (Uns64 (-Lo))) + 1; - else - declare - Wl : constant Width := Width (Clog2 (Uns64 (-Lo))); - Wh : constant Width := Width (Clog2 (Uns64 (Hi) + 1)); - begin - W := Width'Max (Wl, Wh) + 1; - end; - end if; - return W; - end Discrete_Range_Width; - - function In_Bounds (Bnd : Bound_Type; V : Int32) return Boolean is - begin - case Bnd.Dir is - when Dir_To => - return V >= Bnd.Left and then V <= Bnd.Right; - when Dir_Downto => - return V <= Bnd.Left and then V >= Bnd.Right; - end case; - end In_Bounds; - - function In_Range (Rng : Discrete_Range_Type; V : Int64) return Boolean is - begin - case Rng.Dir is - when Dir_To => - return V >= Rng.Left and then V <= Rng.Right; - when Dir_Downto => - return V <= Rng.Left and then V >= Rng.Right; - end case; - end In_Range; - - function Create_Bit_Type return Type_Acc - is - subtype Bit_Type_Type is Type_Type (Type_Bit); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Bit_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Bit, - Is_Synth => True, - Al => 0, - Sz => 1, - W => 1))); - end Create_Bit_Type; - - function Create_Logic_Type return Type_Acc - is - subtype Logic_Type_Type is Type_Type (Type_Logic); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Logic_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Logic, - Is_Synth => True, - Al => 0, - Sz => 1, - W => 1))); - end Create_Logic_Type; - - function Create_Discrete_Type (Rng : Discrete_Range_Type; - Sz : Size_Type; - W : Width) - return Type_Acc - is - subtype Discrete_Type_Type is Type_Type (Type_Discrete); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Discrete_Type_Type); - Al : Palign_Type; - begin - if Sz <= 1 then - Al := 0; - elsif Sz <= 4 then - Al := 2; - else - pragma Assert (Sz <= 8); - Al := 3; - end if; - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Discrete, - Is_Synth => True, - Al => Al, - Sz => Sz, - W => W, - Drange => Rng))); - end Create_Discrete_Type; - - function Create_Float_Type (Rng : Float_Range_Type) return Type_Acc - is - subtype Float_Type_Type is Type_Type (Type_Float); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Float_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Float, - Is_Synth => True, - Al => 3, - Sz => 8, - W => 64, - Frange => Rng))); - end Create_Float_Type; - - function Create_Vector_Type (Bnd : Bound_Type; El_Type : Type_Acc) - return Type_Acc - is - subtype Vector_Type_Type is Type_Type (Type_Vector); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Vector_Type_Type); - begin - return To_Type_Acc - (Alloc (Current_Pool, (Kind => Type_Vector, - Is_Synth => True, - Al => El_Type.Al, - Sz => El_Type.Sz * Size_Type (Bnd.Len), - W => Bnd.Len, - Vbound => Bnd, - Vec_El => El_Type))); - end Create_Vector_Type; - - function Create_Slice_Type (Len : Uns32; El_Type : Type_Acc) - return Type_Acc - is - subtype Slice_Type_Type is Type_Type (Type_Slice); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Slice_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, - (Kind => Type_Slice, - Is_Synth => El_Type.Is_Synth, - Al => El_Type.Al, - Sz => Size_Type (Len) * El_Type.Sz, - W => Len * El_Type.W, - Slice_El => El_Type))); - end Create_Slice_Type; - - function Create_Vec_Type_By_Length (Len : Width; El : Type_Acc) - return Type_Acc is - begin - return Create_Vector_Type ((Dir => Dir_Downto, - Left => Int32 (Len) - 1, - Right => 0, - Len => Len), - El); - end Create_Vec_Type_By_Length; - - function Create_Bound_Array (Ndims : Dim_Type) return Bound_Array_Acc - is - subtype Data_Type is Bound_Array (Ndims); - Res : Address; - begin - -- Manually allocate the array to handle large arrays without - -- creating a large temporary value. - Areapools.Allocate - (Current_Pool.all, Res, - Data_Type'Size / Storage_Unit, Data_Type'Alignment); - - declare - -- Discard the warnings for no pragma Import as we really want - -- to use the default initialization. - pragma Warnings (Off); - Addr1 : constant Address := Res; - Init : Data_Type; - for Init'Address use Addr1; - pragma Warnings (On); - begin - null; - end; - - return To_Bound_Array_Acc (Res); - end Create_Bound_Array; - - function Create_Array_Type (Bnd : Bound_Array_Acc; El_Type : Type_Acc) - return Type_Acc - is - subtype Array_Type_Type is Type_Type (Type_Array); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Array_Type_Type); - L : Uns32; - begin - L := 1; - for I in Bnd.D'Range loop - L := L * Bnd.D (I).Len; - end loop; - return To_Type_Acc (Alloc (Current_Pool, - (Kind => Type_Array, - Is_Synth => El_Type.Is_Synth, - Al => El_Type.Al, - Sz => El_Type.Sz * Size_Type (L), - W => El_Type.W * L, - Abounds => Bnd, - Arr_El => El_Type))); - end Create_Array_Type; - - function Create_Unbounded_Array (Ndim : Dim_Type; El_Type : Type_Acc) - return Type_Acc - is - subtype Unbounded_Type_Type is Type_Type (Type_Unbounded_Array); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Unbounded_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Array, - Is_Synth => El_Type.Is_Synth, - Al => El_Type.Al, - Sz => 0, - W => 0, - Uarr_Ndim => Ndim, - Uarr_El => El_Type))); - end Create_Unbounded_Array; - - function Create_Unbounded_Vector (El_Type : Type_Acc) return Type_Acc - is - subtype Unbounded_Type_Type is Type_Type (Type_Unbounded_Vector); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Unbounded_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Vector, - Is_Synth => El_Type.Is_Synth, - Al => El_Type.Al, - Sz => 0, - W => 0, - Uvec_El => El_Type))); - end Create_Unbounded_Vector; - - function Get_Array_Element (Arr_Type : Type_Acc) return Type_Acc is - begin - case Arr_Type.Kind is - when Type_Vector => - return Arr_Type.Vec_El; - when Type_Array => - return Arr_Type.Arr_El; - when Type_Unbounded_Array => - return Arr_Type.Uarr_El; - when Type_Unbounded_Vector => - return Arr_Type.Uvec_El; - when others => - raise Internal_Error; - end case; - end Get_Array_Element; - - function Get_Array_Bound (Typ : Type_Acc; Dim : Dim_Type) - return Bound_Type is - begin - case Typ.Kind is - when Type_Vector => - if Dim /= 1 then - raise Internal_Error; - end if; - return Typ.Vbound; - when Type_Array => - return Typ.Abounds.D (Dim); - when others => - raise Internal_Error; - end case; - end Get_Array_Bound; - - function Get_Range_Length (Rng : Discrete_Range_Type) return Uns32 - is - Len : Int64; - begin - case Rng.Dir is - when Dir_To => - Len := Rng.Right - Rng.Left + 1; - when Dir_Downto => - Len := Rng.Left - Rng.Right + 1; - end case; - if Len < 0 then - return 0; - else - return Uns32 (Len); - end if; - end Get_Range_Length; - - function Create_Rec_El_Array (Nels : Iir_Index32) return Rec_El_Array_Acc - is - subtype Data_Type is Rec_El_Array (Nels); - Res : Address; - begin - -- Manually allocate the array to handle large arrays without - -- creating a large temporary value. - Areapools.Allocate - (Current_Pool.all, Res, - Data_Type'Size / Storage_Unit, Data_Type'Alignment); - - declare - -- Discard the warnings for no pragma Import as we really want - -- to use the default initialization. - pragma Warnings (Off); - Addr1 : constant Address := Res; - Init : Data_Type; - for Init'Address use Addr1; - pragma Warnings (On); - begin - null; - end; - - return To_Rec_El_Array_Acc (Res); - end Create_Rec_El_Array; - - function Align (Off : Size_Type; Al : Palign_Type) return Size_Type - is - Mask : constant Size_Type := 2 ** Natural (Al) - 1; - begin - return (Off + Mask) and not Mask; - end Align; - - function Create_Record_Type (Els : Rec_El_Array_Acc) - return Type_Acc - is - subtype Record_Type_Type is Type_Type (Type_Record); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Record_Type_Type); - Is_Synth : Boolean; - W : Width; - Al : Palign_Type; - Sz : Size_Type; - begin - -- Layout the record. - Is_Synth := True; - Al := 0; - Sz := 0; - W := 0; - for I in Els.E'Range loop - declare - E : Rec_El_Type renames Els.E (I); - begin - -- For nets. - E.Boff := W; - Is_Synth := Is_Synth and E.Typ.Is_Synth; - W := W + E.Typ.W; - - -- For memory. - Al := Palign_Type'Max (Al, E.Typ.Al); - Sz := Align (Sz, E.Typ.Al); - E.Moff := Sz; - Sz := Sz + E.Typ.Sz; - end; - end loop; - Sz := Align (Sz, Al); - - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Record, - Is_Synth => Is_Synth, - Al => Al, - Sz => Sz, - W => W, - Rec => Els))); - end Create_Record_Type; - - function Create_Unbounded_Record (Els : Rec_El_Array_Acc) return Type_Acc - is - subtype Unbounded_Record_Type_Type is Type_Type (Type_Unbounded_Record); - function Alloc is - new Areapools.Alloc_On_Pool_Addr (Unbounded_Record_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Unbounded_Record, - Is_Synth => True, - Al => 0, - Sz => 0, - W => 0, - Rec => Els))); - end Create_Unbounded_Record; - - function Create_Access_Type (Acc_Type : Type_Acc) return Type_Acc - is - subtype Access_Type_Type is Type_Type (Type_Access); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Access_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Access, - Is_Synth => False, - Al => 2, - Sz => 4, - W => 32, - Acc_Acc => Acc_Type))); - end Create_Access_Type; - - function Create_File_Type (File_Type : Type_Acc) return Type_Acc - is - subtype File_Type_Type is Type_Type (Type_File); - function Alloc is new Areapools.Alloc_On_Pool_Addr (File_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_File, - Is_Synth => False, - Al => 2, - Sz => 4, - W => 32, - File_Typ => File_Type, - File_Signature => null))); - end Create_File_Type; - - function Create_Protected_Type return Type_Acc - is - subtype Protected_Type_Type is Type_Type (Type_Protected); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Protected_Type_Type); - begin - return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Protected, - Is_Synth => False, - Al => 2, - Sz => 4, - W => 32))); - end Create_Protected_Type; - - function Vec_Length (Typ : Type_Acc) return Iir_Index32 is - begin - return Iir_Index32 (Typ.Vbound.Len); - end Vec_Length; - - function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32 is - begin - case Typ.Kind is - when Type_Vector => - return Iir_Index32 (Typ.Vbound.Len); - when Type_Array => - declare - Len : Width; - begin - Len := 1; - for I in Typ.Abounds.D'Range loop - Len := Len * Typ.Abounds.D (I).Len; - end loop; - return Iir_Index32 (Len); - end; - when others => - raise Internal_Error; - end case; - end Get_Array_Flat_Length; - - function Get_Type_Width (Atype : Type_Acc) return Width is - begin - pragma Assert (Atype.Kind /= Type_Unbounded_Array); - return Atype.W; - end Get_Type_Width; - - function Get_Bound_Length (T : Type_Acc; Dim : Dim_Type) return Width is - begin - case T.Kind is - when Type_Vector => - if Dim /= 1 then - raise Internal_Error; - end if; - return T.Vbound.Len; - when Type_Slice => - if Dim /= 1 then - raise Internal_Error; - end if; - return T.W; - when Type_Array => - return T.Abounds.D (Dim).Len; - when others => - raise Internal_Error; - end case; - end Get_Bound_Length; - - function Is_Matching_Bounds (L, R : Type_Acc) return Boolean is - begin - case L.Kind is - when Type_Bit - | Type_Logic - | Type_Discrete - | Type_Float => - pragma Assert (L.Kind = R.Kind); - return True; - when Type_Vector - | Type_Slice => - return Get_Bound_Length (L, 1) = Get_Bound_Length (R, 1); - when Type_Array => - for I in L.Abounds.D'Range loop - if Get_Bound_Length (L, I) /= Get_Bound_Length (R, I) then - return False; - end if; - end loop; - return True; - when Type_Unbounded_Array - | Type_Unbounded_Vector - | Type_Unbounded_Record => - raise Internal_Error; - when Type_Record => - -- FIXME: handle vhdl-08 - return True; - when Type_Access => - return True; - when Type_File - | Type_Protected => - raise Internal_Error; - end case; - end Is_Matching_Bounds; - - function Read_U8 (Mt : Memtyp) return Ghdl_U8 - is - pragma Assert (Mt.Typ.Sz = 1); - begin - return Read_U8 (Mt.Mem); - end Read_U8; - - - function Read_Fp64 (Mt : Memtyp) return Fp64 is - begin - return Read_Fp64 (Mt.Mem); - end Read_Fp64; - - function Read_Discrete (Mt : Memtyp) return Int64 is - begin - case Mt.Typ.Sz is - when 1 => - return Int64 (Read_U8 (Mt.Mem)); - when 4 => - return Int64 (Read_I32 (Mt.Mem)); - when 8 => - return Int64 (Read_I64 (Mt.Mem)); - when others => - raise Internal_Error; - end case; - end Read_Discrete; - - procedure Write_Discrete (Mem : Memory_Ptr; Typ : Type_Acc; Val : Int64) is - begin - case Typ.Sz is - when 1 => - Write_U8 (Mem, Ghdl_U8 (Val)); - when 4 => - Write_I32 (Mem, Ghdl_I32 (Val)); - when 8 => - Write_I64 (Mem, Ghdl_I64 (Val)); - when others => - raise Internal_Error; - end case; - end Write_Discrete; - - function Alloc_Memory (Vtype : Type_Acc) return Memory_Ptr - is - function To_Memory_Ptr is new Ada.Unchecked_Conversion - (System.Address, Memory_Ptr); - M : System.Address; - begin - Areapools.Allocate (Current_Pool.all, M, - Vtype.Sz, Size_Type (2 ** Natural (Vtype.Al))); - return To_Memory_Ptr (M); - end Alloc_Memory; - - function Create_Memory (Vtype : Type_Acc) return Memtyp is - begin - return (Vtype, Alloc_Memory (Vtype)); - end Create_Memory; - - function Create_Memory_Zero (Vtype : Type_Acc) return Memtyp - is - Mem : Memory_Ptr; - begin - Mem := Alloc_Memory (Vtype); - for I in 1 .. Vtype.Sz loop - Write_U8 (Mem + (I - 1), 0); - end loop; - return (Vtype, Mem); - end Create_Memory_Zero; - - function Create_Memory_U8 (Val : Ghdl_U8; Vtype : Type_Acc) - return Memtyp - is - pragma Assert (Vtype.Sz = 1); - Res : Memory_Ptr; - begin - Res := Alloc_Memory (Vtype); - Write_U8 (Res, Val); - return (Vtype, Res); - end Create_Memory_U8; - - function Create_Memory_Fp64 (Val : Fp64; Vtype : Type_Acc) - return Memtyp - is - pragma Assert (Vtype.Sz = 8); - Res : Memory_Ptr; - begin - Res := Alloc_Memory (Vtype); - Write_Fp64 (Res, Val); - return (Vtype, Res); - end Create_Memory_Fp64; - - function Create_Memory_Discrete (Val : Int64; Vtype : Type_Acc) - return Memtyp - is - Res : Memory_Ptr; - begin - Res := Alloc_Memory (Vtype); - case Vtype.Sz is - when 1 => - Write_U8 (Res, Ghdl_U8 (Val)); - when 4 => - Write_I32 (Res, Ghdl_I32 (Val)); - when 8 => - Write_I64 (Res, Ghdl_I64 (Val)); - when others => - raise Internal_Error; - end case; - return (Vtype, Res); - end Create_Memory_Discrete; - - function Is_Equal (L, R : Memtyp) return Boolean is - begin - if L = R then - return True; - end if; - - if L.Typ.Sz /= R.Typ.Sz then - return False; - end if; - - -- FIXME: not correct for records, not correct for floats! - for I in 1 .. L.Typ.Sz loop - if L.Mem (I - 1) /= R.Mem (I - 1) then - return False; - end if; - end loop; - return True; - end Is_Equal; - - procedure Copy_Memory (Dest : Memory_Ptr; Src : Memory_Ptr; Sz : Size_Type) - is - begin - for I in 1 .. Sz loop - Dest (I - 1) := Src (I - 1); - end loop; - end Copy_Memory; - - function Unshare (Src : Memtyp) return Memtyp - is - Res : Memory_Ptr; - begin - Res := Alloc_Memory (Src.Typ); - Copy_Memory (Res, Src.Mem, Src.Typ.Sz); - return (Src.Typ, Res); - end Unshare; - - Bit0_Mem : constant Memory_Element := 0; - Bit1_Mem : constant Memory_Element := 1; - - function To_Memory_Ptr is new Ada.Unchecked_Conversion - (Address, Memory_Ptr); - - procedure Init is - begin - Instance_Pool := Global_Pool'Access; - Boolean_Type := Create_Bit_Type; - Logic_Type := Create_Logic_Type; - Bit_Type := Create_Bit_Type; - - Bit0 := (Bit_Type, To_Memory_Ptr (Bit0_Mem'Address)); - Bit1 := (Bit_Type, To_Memory_Ptr (Bit1_Mem'Address)); - end Init; -end Synth.Objtypes; diff --git a/src/synth/synth-objtypes.ads b/src/synth/synth-objtypes.ads deleted file mode 100644 index 91c26327e..000000000 --- a/src/synth/synth-objtypes.ads +++ /dev/null @@ -1,296 +0,0 @@ --- Values in 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 Areapools; use Areapools; - -with Netlists; use Netlists; - -with Grt.Types; use Grt.Types; - -with Synth.Memtype; use Synth.Memtype; - -with Vhdl.Nodes; use Vhdl.Nodes; - -package Synth.Objtypes is - type Discrete_Range_Type is record - -- An integer range. - Dir : Direction_Type; - - -- Netlist representation: signed or unsigned, width of vector. - Is_Signed : Boolean; - - Left : Int64; - Right : Int64; - end record; - - -- Return the width of RNG. - function Discrete_Range_Width (Rng : Discrete_Range_Type) return Width; - - type Float_Range_Type is record - Dir : Direction_Type; - Left : Fp64; - Right : Fp64; - end record; - - type Bound_Type is record - Dir : Direction_Type; - Left : Int32; - Right : Int32; - Len : Width; - end record; - - type Bound_Array_Type is array (Dim_Type range <>) of Bound_Type; - - type Bound_Array (Ndim : Dim_Type) is record - D : Bound_Array_Type (1 .. Ndim); - end record; - - type Bound_Array_Acc is access Bound_Array; - - type Type_Kind is - ( - Type_Bit, - Type_Logic, - Type_Discrete, - Type_Float, - Type_Vector, - Type_Unbounded_Vector, - - -- A slice is for a slice of vector with dynamic bounds. So the bounds - -- of the result aren't known, but its width is. - Type_Slice, - Type_Array, - Type_Unbounded_Array, - Type_Unbounded_Record, - Type_Record, - - Type_Access, - Type_File, - Type_Protected - ); - - subtype Type_Nets is Type_Kind range Type_Bit .. Type_Logic; - subtype Type_All_Discrete is Type_Kind range Type_Bit .. Type_Discrete; - subtype Type_Records is - Type_Kind range Type_Unbounded_Record .. Type_Record; - - type Type_Type (Kind : Type_Kind); - type Type_Acc is access Type_Type; - - type Rec_El_Type is record - -- Bit offset: offset of the element in a net. - Boff : Uns32; - - -- Memory offset: offset of the element in memory. - Moff : Size_Type; - - -- Type of the element. - Typ : Type_Acc; - end record; - - type Rec_El_Array_Type is array (Iir_Index32 range <>) of Rec_El_Type; - type Rec_El_Array (Len : Iir_Index32) is record - E : Rec_El_Array_Type (1 .. Len); - end record; - - type Rec_El_Array_Acc is access Rec_El_Array; - - -- Power of 2 alignment. - type Palign_Type is range 0 .. 3; - - type Type_Type (Kind : Type_Kind) is record - -- False if the type is not synthesisable: is or contains access/file. - Is_Synth : Boolean; - - -- Alignment (in bytes) for this type. - Al : Palign_Type; - - -- Number of bytes (when in memory) for this type. - Sz : Size_Type; - - -- Number of bits (when in a net) for this type. - -- Can be zero only if the type has only 0 or 1 value (like a discrete - -- type with 1 element, a null vector, or a null array). - -- For non synthesizable types (like files or protected type), just - -- use 32. - W : Width; - - case Kind is - when Type_Bit - | Type_Logic => - null; - when Type_Discrete => - Drange : Discrete_Range_Type; - when Type_Float => - Frange : Float_Range_Type; - when Type_Vector => - Vbound : Bound_Type; - Vec_El : Type_Acc; - when Type_Unbounded_Vector => - Uvec_El : Type_Acc; - when Type_Slice => - Slice_El : Type_Acc; - when Type_Array => - Abounds : Bound_Array_Acc; - Arr_El : Type_Acc; - when Type_Unbounded_Array => - Uarr_Ndim : Dim_Type; - Uarr_El : Type_Acc; - when Type_Record - | Type_Unbounded_Record => - Rec : Rec_El_Array_Acc; - when Type_Access => - Acc_Acc : Type_Acc; - when Type_File => - File_Typ : Type_Acc; - File_Signature : String_Acc; - when Type_Protected => - null; - end case; - end record; - - type Memtyp is record - Typ : Type_Acc; - Mem : Memory_Ptr; - end record; - - Null_Memtyp : constant Memtyp := (null, null); - - -- Offsets for a value. - type Value_Offsets is record - Net_Off : Uns32; - Mem_Off : Size_Type; - end record; - - No_Value_Offsets : constant Value_Offsets := (0, 0); - - function "+" (L, R : Value_Offsets) return Value_Offsets; - - Global_Pool : aliased Areapool; - Expr_Pool : aliased Areapool; - - -- Areapool used by Create_*_Value - Current_Pool : Areapool_Acc := Expr_Pool'Access; - - -- Pool for objects allocated in the current instance. - Instance_Pool : Areapool_Acc; - - -- Types. - function Create_Discrete_Type (Rng : Discrete_Range_Type; - Sz : Size_Type; - W : Width) - return Type_Acc; - - function Create_Float_Type (Rng : Float_Range_Type) return Type_Acc; - function Create_Vec_Type_By_Length (Len : Width; El : Type_Acc) - return Type_Acc; - function Create_Vector_Type (Bnd : Bound_Type; El_Type : Type_Acc) - return Type_Acc; - function Create_Unbounded_Vector (El_Type : Type_Acc) return Type_Acc; - function Create_Slice_Type (Len : Uns32; El_Type : Type_Acc) - return Type_Acc; - function Create_Bound_Array (Ndims : Dim_Type) return Bound_Array_Acc; - function Create_Array_Type (Bnd : Bound_Array_Acc; El_Type : Type_Acc) - return Type_Acc; - function Create_Unbounded_Array (Ndim : Dim_Type; El_Type : Type_Acc) - return Type_Acc; - function Create_Rec_El_Array (Nels : Iir_Index32) return Rec_El_Array_Acc; - - function Create_Record_Type (Els : Rec_El_Array_Acc) return Type_Acc; - function Create_Unbounded_Record (Els : Rec_El_Array_Acc) return Type_Acc; - - function Create_Access_Type (Acc_Type : Type_Acc) return Type_Acc; - - function Create_File_Type (File_Type : Type_Acc) return Type_Acc; - - function Create_Protected_Type return Type_Acc; - - function In_Bounds (Bnd : Bound_Type; V : Int32) return Boolean; - function In_Range (Rng : Discrete_Range_Type; V : Int64) return Boolean; - - -- Return the bounds of dimension DIM of a vector/array. For a vector, - -- DIM must be 1. - function Get_Array_Bound (Typ : Type_Acc; Dim : Dim_Type) - return Bound_Type; - - -- Return the length of RNG. - function Get_Range_Length (Rng : Discrete_Range_Type) return Uns32; - - -- Return the element of a vector/array/unbounded_array. - function Get_Array_Element (Arr_Type : Type_Acc) return Type_Acc; - - function Is_Bounded_Type (Typ : Type_Acc) return Boolean; - - function Are_Types_Equal (L, R : Type_Acc) return Boolean; - - -- Return the length of a vector type. - function Vec_Length (Typ : Type_Acc) return Iir_Index32; - - -- Get the number of indexes in array type TYP without counting - -- sub-elements. - function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32; - - -- Return length of dimension DIM of type T. - function Get_Bound_Length (T : Type_Acc; Dim : Dim_Type) return Width; - - function Is_Matching_Bounds (L, R : Type_Acc) return Boolean; - - function Get_Type_Width (Atype : Type_Acc) return Width; - - -- Low-level functions - - function Read_U8 (Mt : Memtyp) return Ghdl_U8; - function Read_Fp64 (Mt : Memtyp) return Fp64; - - procedure Write_Discrete (Mem : Memory_Ptr; Typ : Type_Acc; Val : Int64); - function Read_Discrete (Mt : Memtyp) return Int64; - - -- Memory allocation. - - function Create_Memory_U8 (Val : Ghdl_U8; Vtype : Type_Acc) - return Memtyp; - function Create_Memory_Fp64 (Val : Fp64; Vtype : Type_Acc) - return Memtyp; - function Create_Memory_Discrete (Val : Int64; Vtype : Type_Acc) - return Memtyp; - - function Alloc_Memory (Vtype : Type_Acc) return Memory_Ptr; - function Create_Memory (Vtype : Type_Acc) return Memtyp; - - -- Like Create_Memory but initialize to 0. To be used only for types - -- of width 0. - function Create_Memory_Zero (Vtype : Type_Acc) return Memtyp; - - function Is_Equal (L, R : Memtyp) return Boolean; - - procedure Copy_Memory (Dest : Memory_Ptr; Src : Memory_Ptr; Sz : Size_Type); - - function Unshare (Src : Memtyp) return Memtyp; - - procedure Init; - - -- Set by Init. - Boolean_Type : Type_Acc := null; - Logic_Type : Type_Acc := null; - Bit_Type : Type_Acc := null; - - -- Also set by init. - Bit0 : Memtyp; - Bit1 : Memtyp; -end Synth.Objtypes; diff --git a/src/synth/synth-static_oper.adb b/src/synth/synth-static_oper.adb index 5eba9c8fb..cc52cd0f4 100644 --- a/src/synth/synth-static_oper.adb +++ b/src/synth/synth-static_oper.adb @@ -24,17 +24,18 @@ with Grt.Types; use Grt.Types; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Ieee.Std_Logic_1164; use Vhdl.Ieee.Std_Logic_1164; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Files; + with Netlists; use Netlists; -with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; with Synth.Source; use Synth.Source; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Vhdl_Oper; with Synth.Ieee.Std_Logic_1164; use Synth.Ieee.Std_Logic_1164; with Synth.Ieee.Numeric_Std; use Synth.Ieee.Numeric_Std; -with Synth.Vhdl_Files; -with Synth.Values; use Synth.Values; package body Synth.Static_Oper is -- As log2(3m) is directly referenced, the program must be linked with -lm @@ -852,7 +853,7 @@ package body Synth.Static_Oper is declare Res : Boolean; begin - Res := Synth.Vhdl_Files.Endfile (Param1.Val.File, Expr); + Res := Elab.Vhdl_Files.Endfile (Param1.Val.File, Expr); return Create_Memory_U8 (Boolean'Pos (Res), Boolean_Type); end; diff --git a/src/synth/synth-static_oper.ads b/src/synth/synth-static_oper.ads index 3178c6448..797b73de6 100644 --- a/src/synth/synth-static_oper.ads +++ b/src/synth/synth-static_oper.ads @@ -16,8 +16,8 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; with Vhdl.Nodes; use Vhdl.Nodes; diff --git a/src/synth/synth-values-debug.adb b/src/synth/synth-values-debug.adb deleted file mode 100644 index a6f887f08..000000000 --- a/src/synth/synth-values-debug.adb +++ /dev/null @@ -1,198 +0,0 @@ --- Values in 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 Simple_IO; use Simple_IO; -with Utils_IO; use Utils_IO; - -with Vhdl.Nodes; use Vhdl.Nodes; - -with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Debug; - -package body Synth.Values.Debug is - procedure Put_Dir (Dir : Direction_Type) is - begin - case Dir is - when Dir_To => - Put ("to"); - when Dir_Downto => - Put ("downto"); - end case; - end Put_Dir; - - procedure Debug_Bound (Bnd : Bound_Type) is - begin - Put_Int32 (Bnd.Left); - Put (' '); - Put_Dir (Bnd.Dir); - Put (' '); - Put_Int32 (Bnd.Right); - Put (" ["); - Put_Uns32 (Bnd.Len); - Put (']'); - end Debug_Bound; - - procedure Debug_Typ1 (T : Type_Acc) is - begin - case T.Kind is - when Type_Bit - | Type_Logic => - Put ("bit/logic"); - when Type_Vector => - Put ("vector ("); - Debug_Bound (T.Vbound); - Put (") of "); - Debug_Typ1 (T.Vec_El); - when Type_Array => - Put ("arr ("); - for I in 1 .. T.Abounds.Ndim loop - if I > 1 then - Put (", "); - end if; - Debug_Bound (T.Abounds.D (I)); - end loop; - Put (") of "); - Debug_Typ1 (T.Arr_El); - when Type_Record => - Put ("rec: ("); - Put (")"); - when Type_Unbounded_Record => - Put ("unbounded record"); - when Type_Discrete => - Put ("discrete: "); - Put_Int64 (T.Drange.Left); - Put (' '); - Put_Dir (T.Drange.Dir); - Put (' '); - Put_Int64 (T.Drange.Right); - if T.Drange.Is_Signed then - Put (" [signed]"); - else - Put (" [unsigned]"); - end if; - when Type_Access => - Put ("access"); - when Type_File => - Put ("file"); - when Type_Float => - Put ("float"); - when Type_Slice => - Put ("slice"); - when Type_Unbounded_Vector => - Put ("unbounded vector"); - when Type_Unbounded_Array => - Put ("unbounded array"); - when Type_Protected => - Put ("protected"); - end case; - Put (' '); - Put (" al="); - Put_Int32 (Int32 (T.Al)); - Put (" sz="); - Put_Uns32 (Uns32 (T.Sz)); - Put (" w="); - Put_Uns32 (Uns32 (T.W)); - end Debug_Typ1; - - procedure Debug_Typ (T : Type_Acc) is - begin - Debug_Typ1 (T); - New_Line; - end Debug_Typ; - - procedure Debug_Memtyp (M : Memtyp) is - begin - case M.Typ.Kind is - when Type_Bit - | Type_Logic => - Put ("bit/logic"); - when Type_Vector => - Put ("vector ("); - Debug_Bound (M.Typ.Vbound); - Put ("): "); - for I in 1 .. M.Typ.Vbound.Len loop - Put_Uns32 (Uns32 (Read_U8 (M.Mem + Size_Type (I - 1)))); - end loop; - when Type_Array => - Put ("arr ("); - for I in 1 .. M.Typ.Abounds.Ndim loop - if I > 1 then - Put (", "); - end if; - Debug_Bound (M.Typ.Abounds.D (I)); - end loop; - Put ("): "); - for I in 1 .. Get_Array_Flat_Length (M.Typ) loop - if I > 1 then - Put (", "); - end if; - Debug_Memtyp - ((M.Typ.Arr_El, M.Mem + Size_Type (I - 1) * M.Typ.Arr_El.Sz)); - end loop; - when Type_Record => - Put ("rec: ("); - for I in M.Typ.Rec.E'Range loop - if I > 1 then - Put (", "); - end if; - Debug_Memtyp - ((M.Typ.Rec.E (I).Typ, M.Mem + M.Typ.Rec.E (I).Moff)); - end loop; - Put (")"); - when Type_Discrete => - Put ("discrete: "); - Put_Int64 (Read_Discrete (M)); - when Type_Access => - Put ("access"); - when Type_File => - Put ("file"); - when Type_Float => - Put ("float"); - when Type_Slice => - Put ("slice"); - when Type_Unbounded_Vector => - Put ("unbounded vector"); - when Type_Unbounded_Array => - Put ("unbounded array"); - when Type_Unbounded_Record => - Put ("unbounded record"); - when Type_Protected => - Put ("protected"); - end case; - New_Line; - end Debug_Memtyp; - - procedure Debug_Valtyp (V : Valtyp) is - begin - case V.Val.Kind is - when Value_Memory - | Value_Const => - Debug_Memtyp (Get_Memtyp (V)); - when Value_Net => - Put_Line (" net"); - when Value_Wire => - Put (" wire"); - Put_Wire_Id (V.Val.W); - New_Line; - when Value_File => - Put_Line ("a file"); - when Value_Alias => - Put_Line ("an alias"); - end case; - end Debug_Valtyp; - -end Synth.Values.Debug; diff --git a/src/synth/synth-values-debug.ads b/src/synth/synth-values-debug.ads deleted file mode 100644 index 38e7ce23d..000000000 --- a/src/synth/synth-values-debug.ads +++ /dev/null @@ -1,23 +0,0 @@ --- Values in 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 . - -package Synth.Values.Debug is - procedure Debug_Valtyp (V : Valtyp); - procedure Debug_Memtyp (M : Memtyp); - procedure Debug_Typ (T : Type_Acc); -end Synth.Values.Debug; diff --git a/src/synth/synth-values.adb b/src/synth/synth-values.adb deleted file mode 100644 index 6f89876b6..000000000 --- a/src/synth/synth-values.adb +++ /dev/null @@ -1,513 +0,0 @@ --- Values in 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 Ada.Unchecked_Conversion; -with System; - -with Grt.Types; use Grt.Types; - -with Vhdl.Nodes; use Vhdl.Nodes; - -package body Synth.Values is - function To_Value_Acc is new Ada.Unchecked_Conversion - (System.Address, Value_Acc); - - function Is_Static (Val : Value_Acc) return Boolean is - begin - case Val.Kind is - when Value_Memory => - return True; - when Value_Net - | Value_Wire => - return False; - when Value_File => - return True; - when Value_Alias => - return Is_Static (Val.A_Obj); - when Value_Const => - return True; - end case; - end Is_Static; - - function Is_Static_Val (Val : Value_Acc) return Boolean is - begin - case Val.Kind is - when Value_Memory => - return True; - when Value_Net => - return False; - when Value_Wire => - if Get_Kind (Val.W) = Wire_Variable then - return Is_Static_Wire (Val.W); - else - -- A signal does not have static values. - return False; - end if; - when Value_File => - return True; - when Value_Const => - return True; - when Value_Alias => - return Is_Static_Val (Val.A_Obj); - end case; - end Is_Static_Val; - - function Strip_Alias_Const (V : Value_Acc) return Value_Acc - is - Res : Value_Acc; - begin - Res := V; - loop - case Res.Kind is - when Value_Const => - Res := Res.C_Val; - when Value_Alias => - if Res.A_Off /= (0, 0) then - raise Internal_Error; - end if; - Res := Res.A_Obj; - when others => - return Res; - end case; - end loop; - end Strip_Alias_Const; - - function Strip_Alias_Const (V : Valtyp) return Valtyp is - begin - return (V.Typ, Strip_Alias_Const (V.Val)); - end Strip_Alias_Const; - - function Is_Equal (L, R : Valtyp) return Boolean is - begin - return Is_Equal (Get_Memtyp (L), Get_Memtyp (R)); - end Is_Equal; - - function Create_Value_Memtyp (Mt : Memtyp) return Valtyp - is - subtype Value_Type_Memory is Value_Type (Value_Memory); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); - Res : Value_Acc; - begin - Res := To_Value_Acc (Alloc (Current_Pool, (Kind => Value_Memory, - Mem => Mt.Mem))); - return (Mt.Typ, Res); - end Create_Value_Memtyp; - - function Create_Value_Wire (W : Wire_Id) return Value_Acc - is - subtype Value_Type_Wire is Value_Type (Values.Value_Wire); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Wire); - begin - return To_Value_Acc (Alloc (Current_Pool, - (Kind => Value_Wire, - W => W))); - end Create_Value_Wire; - - function Create_Value_Wire (W : Wire_Id; Wtype : Type_Acc) return Valtyp - is - pragma Assert (Wtype /= null); - begin - return (Wtype, Create_Value_Wire (W)); - end Create_Value_Wire; - - function Create_Value_Net (N : Net) return Value_Acc - is - subtype Value_Type_Net is Value_Type (Value_Net); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Net); - begin - return To_Value_Acc - (Alloc (Current_Pool, Value_Type_Net'(Kind => Value_Net, N => N))); - end Create_Value_Net; - - function Create_Value_Net (N : Net; Ntype : Type_Acc) return Valtyp - is - pragma Assert (Ntype /= null); - begin - return (Ntype, Create_Value_Net (N)); - end Create_Value_Net; - - function Create_Value_Memory (Vtype : Type_Acc) return Valtyp - is - subtype Value_Type_Memory is Value_Type (Value_Memory); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); - function To_Memory_Ptr is new Ada.Unchecked_Conversion - (System.Address, Memory_Ptr); - V : Value_Acc; - M : System.Address; - begin - Areapools.Allocate (Current_Pool.all, M, - Vtype.Sz, Size_Type (2 ** Natural (Vtype.Al))); - V := To_Value_Acc - (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory, - Mem => To_Memory_Ptr (M)))); - - return (Vtype, V); - end Create_Value_Memory; - - function Create_Value_Memory (Mt : Memtyp) return Valtyp - is - subtype Value_Type_Memory is Value_Type (Value_Memory); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory); - V : Value_Acc; - begin - V := To_Value_Acc - (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory, - Mem => Mt.Mem))); - - return (Mt.Typ, V); - end Create_Value_Memory; - - function Create_Value_File (File : File_Index) return Value_Acc - is - subtype Value_Type_File is Value_Type (Value_File); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_File); - begin - return To_Value_Acc (Alloc (Current_Pool, - (Kind => Value_File, File => File))); - end Create_Value_File; - - function Create_Value_File (Vtype : Type_Acc; File : File_Index) - return Valtyp - is - pragma Assert (Vtype /= null); - begin - return (Vtype, Create_Value_File (File)); - end Create_Value_File; - - function Vec_Length (Typ : Type_Acc) return Iir_Index32 is - begin - return Iir_Index32 (Typ.Vbound.Len); - end Vec_Length; - - function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32 is - begin - case Typ.Kind is - when Type_Vector => - return Iir_Index32 (Typ.Vbound.Len); - when Type_Array => - declare - Len : Width; - begin - Len := 1; - for I in Typ.Abounds.D'Range loop - Len := Len * Typ.Abounds.D (I).Len; - end loop; - return Iir_Index32 (Len); - end; - when others => - raise Internal_Error; - end case; - end Get_Array_Flat_Length; - - function Create_Value_Alias - (Obj : Valtyp; Off : Value_Offsets; Typ : Type_Acc) return Valtyp - is - pragma Assert (Typ /= null); - subtype Value_Type_Alias is Value_Type (Value_Alias); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Alias); - Val : Value_Acc; - begin - Val := To_Value_Acc (Alloc (Current_Pool, - (Kind => Value_Alias, - A_Obj => Obj.Val, - A_Typ => Obj.Typ, - A_Off => Off))); - return (Typ, Val); - end Create_Value_Alias; - - function Create_Value_Const (Val : Value_Acc; Loc : Syn_Src) - return Value_Acc - is - subtype Value_Type_Const is Value_Type (Value_Const); - function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Const); - begin - pragma Assert (Val = null or else Val.Kind /= Value_Const); - return To_Value_Acc (Alloc (Current_Pool, - (Kind => Value_Const, - C_Val => Val, - C_Loc => Loc, - C_Net => No_Net))); - end Create_Value_Const; - - function Create_Value_Const (Val : Valtyp; Loc : Syn_Src) - return Valtyp is - begin - return (Val.Typ, Create_Value_Const (Val.Val, Loc)); - end Create_Value_Const; - - procedure Strip_Const (Vt : in out Valtyp) is - begin - if Vt.Val.Kind = Value_Const then - Vt.Val := Vt.Val.C_Val; - end if; - end Strip_Const; - - procedure Write_Value (Dest : Memory_Ptr; Vt : Valtyp) - is - Mt : Memtyp; - begin - Mt := Get_Memtyp (Vt); - Copy_Memory (Dest, Mt.Mem, Mt.Typ.Sz); - end Write_Value; - - function Copy (Src : Valtyp) return Valtyp - is - Res : Valtyp; - begin - case Src.Val.Kind is - when Value_Memory => - Res := Create_Value_Memory (Src.Typ); - for I in 1 .. Src.Typ.Sz loop - Res.Val.Mem (I - 1) := Src.Val.Mem (I - 1); - end loop; - when Value_Net => - Res := Create_Value_Net (Src.Val.N, Src.Typ); - when Value_Wire => - Res := Create_Value_Wire (Src.Val.W, Src.Typ); - when Value_File => - Res := Create_Value_File (Src.Typ, Src.Val.File); - when Value_Const => - raise Internal_Error; - when Value_Alias => - raise Internal_Error; - end case; - return Res; - end Copy; - - function Unshare (Src : Valtyp; Pool : Areapool_Acc) return Valtyp - is - Prev_Pool : constant Areapool_Acc := Current_Pool; - Res : Valtyp; - begin - Current_Pool := Pool; - Res := Copy (Src); - Current_Pool := Prev_Pool; - return Res; - end Unshare; - - procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index) - is - V : Heap_Index; - for V'Address use Mem.all'Address; - pragma Import (Ada, V); - begin - V := Val; - end Write_Access; - - function Read_Access (Mem : Memory_Ptr) return Heap_Index - is - V : Heap_Index; - for V'Address use Mem.all'Address; - pragma Import (Ada, V); - begin - return V; - end Read_Access; - - function Read_Access (Mt : Memtyp) return Heap_Index is - begin - return Read_Access (Mt.Mem); - end Read_Access; - - procedure Write_Discrete (Vt : Valtyp; Val : Int64) is - begin - Write_Discrete (Vt.Val.Mem, Vt.Typ, Val); - end Write_Discrete; - - function Read_Discrete (Vt : Valtyp) return Int64 is - begin - return Read_Discrete (Get_Memtyp (Vt)); - end Read_Discrete; - - function Create_Value_Float (Val : Fp64; Vtype : Type_Acc) return Valtyp - is - Res : Valtyp; - pragma Assert (Vtype /= null); - begin - Res := Create_Value_Memory (Vtype); - Write_Fp64 (Res.Val.Mem, Val); - return Res; - end Create_Value_Float; - - function Read_Fp64 (Vt : Valtyp) return Fp64 is - begin - pragma Assert (Vt.Typ.Kind = Type_Float); - pragma Assert (Vt.Typ.Sz = 8); - return Read_Fp64 (Vt.Val.Mem); - end Read_Fp64; - - function Read_Access (Vt : Valtyp) return Heap_Index is - begin - pragma Assert (Vt.Typ.Kind = Type_Access); - return Read_Access (Vt.Val.Mem); - end Read_Access; - - function Create_Value_Discrete (Val : Int64; Vtype : Type_Acc) return Valtyp - is - Res : Valtyp; - begin - Res := Create_Value_Memory (Vtype); - case Vtype.Sz is - when 1 => - Write_U8 (Res.Val.Mem, Ghdl_U8 (Val)); - when 4 => - Write_I32 (Res.Val.Mem, Ghdl_I32 (Val)); - when 8 => - Write_I64 (Res.Val.Mem, Ghdl_I64 (Val)); - when others => - raise Internal_Error; - end case; - return Res; - end Create_Value_Discrete; - - function Create_Value_Uns (Val : Uns64; Vtype : Type_Acc) return Valtyp - is - Res : Valtyp; - begin - Res := Create_Value_Memory (Vtype); - case Vtype.Sz is - when 1 => - Write_U8 (Res.Val.Mem, Ghdl_U8 (Val)); - when 4 => - Write_U32 (Res.Val.Mem, Ghdl_U32 (Val)); - when others => - raise Internal_Error; - end case; - return Res; - end Create_Value_Uns; - - function Create_Value_Int (Val : Int64; Vtype : Type_Acc) return Valtyp - is - Res : Valtyp; - begin - Res := Create_Value_Memory (Vtype); - case Vtype.Sz is - when 4 => - Write_I32 (Res.Val.Mem, Ghdl_I32 (Val)); - when 8 => - Write_I64 (Res.Val.Mem, Ghdl_I64 (Val)); - when others => - raise Internal_Error; - end case; - return Res; - end Create_Value_Int; - - function Arr_Index (M : Memory_Ptr; Idx : Iir_Index32; El_Typ : Type_Acc) - return Memory_Ptr is - begin - return M + Size_Type (Idx) * El_Typ.Sz; - end Arr_Index; - - procedure Write_Value_Default (M : Memory_Ptr; Typ : Type_Acc) is - begin - case Typ.Kind is - when Type_Bit - | Type_Logic => - -- FIXME: what about subtype ? - Write_U8 (M, 0); - when Type_Discrete => - Write_Discrete (M, Typ, Typ.Drange.Left); - when Type_Float => - Write_Fp64 (M, Typ.Frange.Left); - when Type_Vector => - declare - Len : constant Iir_Index32 := Vec_Length (Typ); - El_Typ : constant Type_Acc := Typ.Vec_El; - begin - for I in 1 .. Len loop - Write_Value_Default (Arr_Index (M, I - 1, El_Typ), El_Typ); - end loop; - end; - when Type_Unbounded_Vector - | Type_Unbounded_Array - | Type_Unbounded_Record => - raise Internal_Error; - when Type_Slice => - raise Internal_Error; - when Type_Array => - declare - Len : constant Iir_Index32 := Get_Array_Flat_Length (Typ); - El_Typ : constant Type_Acc := Typ.Arr_El; - begin - for I in 1 .. Len loop - Write_Value_Default (Arr_Index (M, I - 1, El_Typ), El_Typ); - end loop; - end; - when Type_Record => - for I in Typ.Rec.E'Range loop - Write_Value_Default (M + Typ.Rec.E (I).Moff, Typ.Rec.E (I).Typ); - end loop; - when Type_Access => - Write_Access (M, Null_Heap_Index); - when Type_File - | Type_Protected => - raise Internal_Error; - end case; - end Write_Value_Default; - - function Create_Value_Default (Typ : Type_Acc) return Valtyp - is - Res : Valtyp; - begin - Res := Create_Value_Memory (Typ); - Write_Value_Default (Res.Val.Mem, Typ); - return Res; - end Create_Value_Default; - - function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc) - return Valtyp - is - Res : Valtyp; - begin - Res := Create_Value_Memory (Acc_Typ); - Write_Access (Res.Val.Mem, Val); - return Res; - end Create_Value_Access; - - function Value_To_String (Val : Valtyp) return String - is - Str : String (1 .. Natural (Val.Typ.Abounds.D (1).Len)); - begin - for I in Str'Range loop - Str (Natural (I)) := Character'Val - (Read_U8 (Val.Val.Mem + Size_Type (I - 1))); - end loop; - return Str; - end Value_To_String; - - function Get_Memtyp (V : Valtyp) return Memtyp is - begin - case V.Val.Kind is - when Value_Net - | Value_Wire => - raise Internal_Error; - when Value_Memory => - return (V.Typ, V.Val.Mem); - when Value_Alias => - declare - T : Memtyp; - begin - T := Get_Memtyp ((V.Typ, V.Val.A_Obj)); - return (T.Typ, T.Mem + V.Val.A_Off.Mem_Off); - end; - when Value_Const => - return Get_Memtyp ((V.Typ, V.Val.C_Val)); - when Value_File => - raise Internal_Error; - end case; - end Get_Memtyp; -end Synth.Values; diff --git a/src/synth/synth-values.ads b/src/synth/synth-values.ads deleted file mode 100644 index f5db25da6..000000000 --- a/src/synth/synth-values.ads +++ /dev/null @@ -1,176 +0,0 @@ --- Values in 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 Ada.Unchecked_Deallocation; - -with Types; use Types; -with Areapools; use Areapools; - -with Grt.Files_Operations; - -with Netlists; use Netlists; - -with Synth.Memtype; use Synth.Memtype; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; -with Synth.Source; use Synth.Source; - -package Synth.Values is - -- Values is how signals and variables are decomposed. This is similar to - -- values in simulation, but simplified (no need to handle files, - -- accesses...) - - type Value_Kind is - ( - -- Value is for a vector or a bit, and is the output of a gate. - Value_Net, - - -- Also a vector or a bit, but from an object. Has to be transformed - -- into a net. - Value_Wire, - - -- Any kind of constant value, raw stored in memory. - Value_Memory, - - Value_File, - - -- A constant. This is a named value. One purpose is to avoid to - -- create many times the same net for the same value. - Value_Const, - - -- An alias. This is a reference to another value with a different - -- (but compatible) type. - Value_Alias - ); - - type Value_Type (Kind : Value_Kind); - - type Value_Acc is access Value_Type; - - type Heap_Index is new Uns32; - Null_Heap_Index : constant Heap_Index := 0; - - subtype File_Index is Grt.Files_Operations.Ghdl_File_Index; - - type Value_Type (Kind : Value_Kind) is record - case Kind is - when Value_Net => - N : Net; - when Value_Wire => - W : Wire_Id; - when Value_Memory => - Mem : Memory_Ptr; - when Value_File => - File : File_Index; - when Value_Const => - C_Val : Value_Acc; - C_Loc : Syn_Src; - C_Net : Net; - when Value_Alias => - A_Obj : Value_Acc; - A_Typ : Type_Acc; -- The type of A_Obj. - A_Off : Value_Offsets; - end case; - end record; - - -- A tuple of type and value. - type Valtyp is record - Typ : Type_Acc; - Val : Value_Acc; - end record; - - No_Valtyp : constant Valtyp := (null, null); - - type Valtyp_Array is array (Nat32 range <>) of Valtyp; - type Valtyp_Array_Acc is access Valtyp_Array; - - procedure Free_Valtyp_Array is new Ada.Unchecked_Deallocation - (Valtyp_Array, Valtyp_Array_Acc); - - -- True if VAL is static, ie contains neither nets nor wires. - function Is_Static (Val : Value_Acc) return Boolean; - - -- Can also return true for nets and wires. - -- Use Get_Static_Discrete to get the value. - function Is_Static_Val (Val : Value_Acc) return Boolean; - - function Is_Equal (L, R : Valtyp) return Boolean; - - function Create_Value_Memtyp (Mt : Memtyp) return Valtyp; - - -- Create a Value_Net. - function Create_Value_Net (N : Net; Ntype : Type_Acc) return Valtyp; - - -- Create a Value_Wire. For a bit wire, RNG must be null. - function Create_Value_Wire (W : Wire_Id; Wtype : Type_Acc) return Valtyp; - - function Create_Value_Memory (Vtype : Type_Acc) return Valtyp; - function Create_Value_Memory (Mt : Memtyp) return Valtyp; - - function Create_Value_Uns (Val : Uns64; Vtype : Type_Acc) return Valtyp; - function Create_Value_Int (Val : Int64; Vtype : Type_Acc) return Valtyp; - function Create_Value_Discrete (Val : Int64; Vtype : Type_Acc) - return Valtyp; - - function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc) - return Valtyp; - - function Create_Value_Float (Val : Fp64; Vtype : Type_Acc) return Valtyp; - - function Create_Value_File (Vtype : Type_Acc; File : File_Index) - return Valtyp; - - function Create_Value_Alias - (Obj : Valtyp; Off : Value_Offsets; Typ : Type_Acc) return Valtyp; - - function Create_Value_Const (Val : Valtyp; Loc : Syn_Src) - return Valtyp; - - -- If VAL is a const, replace it by its value. - procedure Strip_Const (Vt : in out Valtyp); - - -- If VAL is a const or an alias, replace it by its value. - -- Used to extract the real data of a static value. Note that the type - -- is not correct anymore. - function Strip_Alias_Const (V : Valtyp) return Valtyp; - - -- Return the memtyp of V; also strip const and aliases. - function Get_Memtyp (V : Valtyp) return Memtyp; - - function Unshare (Src : Valtyp; Pool : Areapool_Acc) return Valtyp; - - -- Create a default initial value for TYP. - function Create_Value_Default (Typ : Type_Acc) return Valtyp; - procedure Write_Value_Default (M : Memory_Ptr; Typ : Type_Acc); - - -- Convert a value to a string. The value must be a const_array of scalar, - -- which represent characters. - function Value_To_String (Val : Valtyp) return String; - - -- Memory access. - procedure Write_Discrete (Vt : Valtyp; Val : Int64); - function Read_Discrete (Vt : Valtyp) return Int64; - - procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index); - function Read_Access (Mt : Memtyp) return Heap_Index; - function Read_Access (Vt : Valtyp) return Heap_Index; - - function Read_Fp64 (Vt : Valtyp) return Fp64; - - procedure Write_Value (Dest : Memory_Ptr; Vt : Valtyp); -end Synth.Values; diff --git a/src/synth/synth-vhdl_aggr.adb b/src/synth/synth-vhdl_aggr.adb index fe7e95058..6ba9fda0d 100644 --- a/src/synth/synth-vhdl_aggr.adb +++ b/src/synth/synth-vhdl_aggr.adb @@ -26,11 +26,12 @@ with Netlists.Builders; use Netlists.Builders; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; + with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; -with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; -with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; package body Synth.Vhdl_Aggr is type Stride_Array is array (Dim_Type range <>) of Nat32; diff --git a/src/synth/synth-vhdl_aggr.ads b/src/synth/synth-vhdl_aggr.ads index 822c0705d..97e3030fe 100644 --- a/src/synth/synth-vhdl_aggr.ads +++ b/src/synth/synth-vhdl_aggr.ads @@ -18,9 +18,9 @@ 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; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; package Synth.Vhdl_Aggr is -- Aggr_Type is the type from the context. diff --git a/src/synth/synth-vhdl_context.adb b/src/synth/synth-vhdl_context.adb index 4b32b7efd..a01ad9db0 100644 --- a/src/synth/synth-vhdl_context.adb +++ b/src/synth/synth-vhdl_context.adb @@ -16,37 +16,36 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -with Ada.Unchecked_Deallocation; - +with Ada.Unchecked_Conversion; +with Tables; with Types_Utils; use Types_Utils; -with Vhdl.Errors; use Vhdl.Errors; -with Vhdl.Utils; - with Netlists.Folds; use Netlists.Folds; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Netlists.Locations; package body Synth.Vhdl_Context is - function Make_Base_Instance (Base : Base_Instance_Acc) - return Synth_Instance_Acc + package Extra_Tables is new Tables + (Table_Component_Type => Extra_Vhdl_Instance_Type, + Table_Index_Type => Instance_Id_Type, + Table_Low_Bound => First_Instance_Id, + Table_Initial => 16); + + procedure Set_Extra (Inst : Synth_Instance_Acc; + Extra : Extra_Vhdl_Instance_Type) is - Res : Synth_Instance_Acc; + Id : constant Instance_Id_Type := Get_Instance_Id (Inst); begin - Res := new Synth_Instance_Type'(Max_Objs => Global_Info.Nbr_Objects, - Is_Const => False, - Is_Error => False, - Base => Base, - Name => No_Sname, - Block_Scope => Global_Info, - Up_Block => null, - Uninst_Scope => null, - Source_Scope => Null_Node, - Elab_Objects => 0, - Objects => (others => - (Kind => Obj_None))); - return Res; + while Id > Extra_Tables.Last loop + Extra_Tables.Append ((Base => null, Name => No_Sname)); + end loop; + Extra_Tables.Table (Id) := Extra; + end Set_Extra; + + procedure Make_Base_Instance (Base : Base_Instance_Acc) is + begin + Set_Extra (Root_Instance, (Base => Base, Name => No_Sname)); end Make_Base_Instance; procedure Free_Base_Instance is @@ -55,54 +54,62 @@ package body Synth.Vhdl_Context is null; end Free_Base_Instance; + function Get_Instance_Extra (Inst : Synth_Instance_Acc) + return Extra_Vhdl_Instance_Type is + begin + return Extra_Tables.Table (Get_Instance_Id (Inst)); + end Get_Instance_Extra; + + procedure Set_Extra (Inst : Synth_Instance_Acc; + Base : Base_Instance_Acc; + Name : Sname := No_Sname) is + begin + Set_Extra (Inst, (Base => Base, Name => Name)); + end Set_Extra; + + procedure Set_Extra (Inst : Synth_Instance_Acc; + Parent : Synth_Instance_Acc; + Name : Sname := No_Sname) is + begin + Set_Extra (Inst, (Base => Get_Instance_Extra (Parent).Base, + Name => Name)); + end Set_Extra; + function Make_Instance (Parent : Synth_Instance_Acc; Blk : Node; Name : Sname := No_Sname) return Synth_Instance_Acc is - Info : constant Sim_Info_Acc := Get_Info (Blk); - Scope : Sim_Info_Acc; Res : Synth_Instance_Acc; begin - if Get_Kind (Blk) = Iir_Kind_Architecture_Body then - -- Architectures are extensions of entities. - Scope := Get_Info (Vhdl.Utils.Get_Entity (Blk)); - else - Scope := Info; - end if; - - Res := new Synth_Instance_Type'(Max_Objs => Info.Nbr_Objects, - Is_Const => False, - Is_Error => False, - Base => Parent.Base, - Name => Name, - Block_Scope => Scope, - Up_Block => Parent, - Uninst_Scope => null, - Source_Scope => Blk, - Elab_Objects => 0, - Objects => (others => - (Kind => Obj_None))); + Res := Make_Elab_Instance (Parent, Blk, Null_Node); + Set_Extra (Res, Parent, Name); return Res; end Make_Instance; + procedure Set_Instance_Base (Inst : Synth_Instance_Acc; + Base : Base_Instance_Acc) is + begin + Extra_Tables.Table (Get_Instance_Id (Inst)).Base := Base; + end Set_Instance_Base; + procedure Set_Instance_Base (Inst : Synth_Instance_Acc; Base : Synth_Instance_Acc) is begin - Inst.Base := Base.Base; + Set_Instance_Base (Inst, Get_Instance_Extra (Base).Base); end Set_Instance_Base; - procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc) - is - procedure Deallocate is new Ada.Unchecked_Deallocation - (Synth_Instance_Type, Synth_Instance_Acc); + procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc) is begin - Deallocate (Synth_Inst); + if Get_Instance_Id (Synth_Inst) = Extra_Tables.Last then + Extra_Tables.Decrement_Last; + end if; + Free_Elab_Instance (Synth_Inst); end Free_Instance; procedure Set_Instance_Module (Inst : Synth_Instance_Acc; M : Module) is - Prev_Base : constant Base_Instance_Acc := Inst.Base; + Prev_Base : constant Base_Instance_Acc := Get_Instance_Extra (Inst).Base; Base : Base_Instance_Acc; Self_Inst : Instance; begin @@ -114,184 +121,42 @@ package body Synth.Vhdl_Context is Self_Inst := Create_Self_Instance (M); pragma Unreferenced (Self_Inst); - Inst.Base := Base; + Set_Instance_Base (Inst, Base); end Set_Instance_Module; - function Is_Error (Inst : Synth_Instance_Acc) return Boolean is - begin - return Inst.Is_Error; - end Is_Error; - - procedure Set_Error (Inst : Synth_Instance_Acc) is - begin - Inst.Is_Error := True; - end Set_Error; - function Get_Instance_Module (Inst : Synth_Instance_Acc) return Module is begin - return Inst.Base.Cur_Module; + return Extra_Tables.Table (Get_Instance_Id (Inst)).Base.Cur_Module; end Get_Instance_Module; - function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node is - begin - return Inst.Source_Scope; - end Get_Source_Scope; - function Get_Top_Module (Inst : Synth_Instance_Acc) return Module is begin - return Inst.Base.Top_Module; + return Extra_Tables.Table (Get_Instance_Id (Inst)).Base.Top_Module; end Get_Top_Module; function Get_Sname (Inst : Synth_Instance_Acc) return Sname is begin - return Inst.Name; + return Extra_Tables.Table (Get_Instance_Id (Inst)).Name; end Get_Sname; function Get_Build (Inst : Synth_Instance_Acc) - return Netlists.Builders.Context_Acc is - begin - return Inst.Base.Builder; - end Get_Build; - - function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean is - begin - return Inst.Is_Const; - end Get_Instance_Const; - - function Check_Set_Instance_Const (Inst : Synth_Instance_Acc) - return Boolean is - begin - for I in 1 .. Inst.Elab_Objects loop - if Inst.Objects (I).Kind /= Obj_Subtype then - return False; - end if; - end loop; - return True; - end Check_Set_Instance_Const; - - procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean) is - begin - pragma Assert (not Val or else Check_Set_Instance_Const (Inst)); - Inst.Is_Const := Val; - end Set_Instance_Const; - - procedure Create_Object (Syn_Inst : Synth_Instance_Acc; - Slot : Object_Slot_Type; - Num : Object_Slot_Type := 1) is - begin - -- Check elaboration order. - -- Note: this is not done for package since objects from package are - -- commons (same scope), and package annotation order can be different - -- from package elaboration order (eg: body). - if Slot /= Syn_Inst.Elab_Objects + 1 - or else Syn_Inst.Objects (Slot).Kind /= Obj_None - then - Error_Msg_Elab ("synth: bad elaboration order of objects"); - raise Internal_Error; - end if; - Syn_Inst.Elab_Objects := Slot + Num - 1; - end Create_Object; - - procedure Create_Object_Force - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) + return Netlists.Builders.Context_Acc is - Info : constant Sim_Info_Acc := Get_Info (Decl); - begin - pragma Assert - (Syn_Inst.Objects (Info.Slot).Kind = Obj_None - or else Vt = (null, null) - or else Syn_Inst.Objects (Info.Slot) = (Kind => Obj_Object, - Obj => No_Valtyp)); - Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Object, Obj => Vt); - end Create_Object_Force; - - procedure Create_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - begin - Create_Object (Syn_Inst, Info.Slot, 1); - Create_Object_Force (Syn_Inst, Decl, Vt); - end Create_Object; - - procedure Create_Subtype_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc) - is - pragma Assert (Typ /= null); - Info : constant Sim_Info_Acc := Get_Info (Decl); - begin - Create_Object (Syn_Inst, Info.Slot, 1); - pragma Assert (Syn_Inst.Objects (Info.Slot).Kind = Obj_None); - Syn_Inst.Objects (Info.Slot) := (Kind => Obj_Subtype, T_Typ => Typ); - end Create_Subtype_Object; - - procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc; - Decl : Node; - Inst : Synth_Instance_Acc; - Is_Global : Boolean) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); + Id : constant Instance_Id_Type := Get_Instance_Id (Inst); + Base : Base_Instance_Acc; begin - if Is_Global then - pragma Assert (Syn_Inst.Objects (Info.Pkg_Slot).Kind = Obj_None); - pragma Assert (Syn_Inst.Up_Block = null); - null; - else - pragma Assert (Syn_Inst.Up_Block /= null); - Create_Object (Syn_Inst, Info.Slot, 1); + if Id > Extra_Tables.Last then + -- Not yet built. + return null; end if; - Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, - I_Inst => Inst); - end Create_Package_Object; - procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc; - Decl : Node; - Inst : Synth_Instance_Acc) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - begin - pragma Assert (Syn_Inst.Up_Block /= null); - Create_Object (Syn_Inst, Info.Pkg_Slot, 1); - Syn_Inst.Objects (Info.Pkg_Slot) := (Kind => Obj_Instance, - I_Inst => Inst); - end Create_Package_Interface; - - function Get_Package_Object - (Syn_Inst : Synth_Instance_Acc; Info : Sim_Info_Acc) - return Synth_Instance_Acc - is - Parent : Synth_Instance_Acc; - begin - Parent := Get_Instance_By_Scope (Syn_Inst, Info.Pkg_Parent); - return Parent.Objects (Info.Pkg_Slot).I_Inst; - end Get_Package_Object; - - function Get_Package_Object - (Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc is - begin - return Get_Package_Object (Syn_Inst, Get_Info (Pkg)); - end Get_Package_Object; - - procedure Set_Uninstantiated_Scope - (Syn_Inst : Synth_Instance_Acc; Bod : Node) is - begin - Syn_Inst.Uninst_Scope := Get_Info (Bod); - end Set_Uninstantiated_Scope; - - procedure Destroy_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - Slot : constant Object_Slot_Type := Info.Slot; - begin - if Slot /= Syn_Inst.Elab_Objects - or else Info.Obj_Scope /= Syn_Inst.Block_Scope - then - Error_Msg_Elab ("synth: bad destroy order"); + Base := Extra_Tables.Table (Id).Base; + if Base = null then + return null; end if; - Syn_Inst.Objects (Slot) := (Kind => Obj_None); - Syn_Inst.Elab_Objects := Slot - 1; - end Destroy_Object; + + return Base.Builder; + end Get_Build; procedure Create_Wire_Object (Syn_Inst : Synth_Instance_Acc; Kind : Wire_Kind; @@ -312,81 +177,6 @@ package body Synth.Vhdl_Context is Create_Object (Syn_Inst, Obj, Val); end Create_Wire_Object; - function Get_Instance_By_Scope - (Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc) - return Synth_Instance_Acc is - begin - case Scope.Kind is - when Kind_Block - | Kind_Frame - | Kind_Process => - declare - Current : Synth_Instance_Acc; - begin - Current := Syn_Inst; - while Current /= null loop - if Current.Block_Scope = Scope then - return Current; - end if; - Current := Current.Up_Block; - end loop; - raise Internal_Error; - end; - when Kind_Package => - if Scope.Pkg_Parent = null then - -- This is a scope for an uninstantiated package. - declare - Current : Synth_Instance_Acc; - begin - Current := Syn_Inst; - while Current /= null loop - if Current.Uninst_Scope = Scope then - return Current; - end if; - Current := Current.Up_Block; - end loop; - raise Internal_Error; - end; - else - -- Instantiated package. - return Get_Package_Object (Syn_Inst, Scope); - end if; - when others => - raise Internal_Error; - end case; - end Get_Instance_By_Scope; - - function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc - is - Parent : Node; - begin - Parent := Get_Parent (Blk); - if Get_Kind (Parent) = Iir_Kind_Architecture_Body then - Parent := Vhdl.Utils.Get_Entity (Parent); - end if; - return Get_Info (Parent); - end Get_Parent_Scope; - - function Get_Value (Syn_Inst: Synth_Instance_Acc; Obj : Node) - return Valtyp - is - Info : constant Sim_Info_Acc := Get_Info (Obj); - Obj_Inst : Synth_Instance_Acc; - begin - Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); - return Obj_Inst.Objects (Info.Slot).Obj; - end Get_Value; - - function Get_Subtype_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - Obj_Inst : Synth_Instance_Acc; - begin - Obj_Inst := Get_Instance_By_Scope (Syn_Inst, Info.Obj_Scope); - return Obj_Inst.Objects (Info.Slot).T_Typ; - end Get_Subtype_Object; - -- Set Is_0 to True iff VEC is 000... -- Set Is_X to True iff VEC is XXX... procedure Is_Full (Vec : Logvec_Array; @@ -529,19 +319,75 @@ package body Synth.Vhdl_Context is return Get_Partial_Memtyp_Net (Ctxt, Val, 0, Val.Typ.W); end Get_Memtyp_Net; + function To_Net is new Ada.Unchecked_Conversion (Uns32, Net); + function To_Uns32 is new Ada.Unchecked_Conversion (Net, Uns32); + + function Get_Value_Net (Val : Value_Acc) return Net is + begin + return To_Net (Val.N); + end Get_Value_Net; + + procedure Set_Value_Net (Val : Value_Acc; N : Net) is + begin + Val.N := To_Uns32 (N); + end Set_Value_Net; + + function Get_Value_Wire (Val : Value_Acc) return Wire_Id + is + function To_Wire_Id is new Ada.Unchecked_Conversion (Uns32, Wire_Id); + begin + return To_Wire_Id (Val.N); + end Get_Value_Wire; + + procedure Set_Value_Wire (Val : Value_Acc; W : Wire_Id) + is + function To_Uns32 is new Ada.Unchecked_Conversion (Wire_Id, Uns32); + begin + Val.N := To_Uns32 (W); + end Set_Value_Wire; + + function Create_Value_Wire (W : Wire_Id) return Value_Acc + is + function To_Uns32 is new Ada.Unchecked_Conversion (Wire_Id, Uns32); + begin + return Create_Value_Wire (To_Uns32 (W)); + end Create_Value_Wire; + + function Create_Value_Wire (W : Wire_Id; Wtype : Type_Acc) return Valtyp + is + pragma Assert (Wtype /= null); + begin + return (Wtype, Create_Value_Wire (W)); + end Create_Value_Wire; + + function Create_Value_Net (N : Net) return Value_Acc + is + function To_Uns32 is new Ada.Unchecked_Conversion (Net, Uns32); + begin + return Create_Value_Net (To_Uns32 (N)); + end Create_Value_Net; + + function Create_Value_Net (N : Net; Ntype : Type_Acc) return Valtyp + is + pragma Assert (Ntype /= null); + begin + return (Ntype, Create_Value_Net (N)); + end Create_Value_Net; + function Get_Net (Ctxt : Context_Acc; Val : Valtyp) return Net is begin case Val.Val.Kind is when Value_Wire => - return Get_Current_Value (Ctxt, Val.Val.W); + return Get_Current_Value (Ctxt, Get_Value_Wire (Val.Val)); when Value_Net => - return Val.Val.N; + return Get_Value_Net (Val.Val); when Value_Alias => declare Res : Net; begin if Val.Val.A_Obj.Kind = Value_Wire then - Res := Get_Current_Value (Ctxt, Val.Val.A_Obj.W); + Res := Get_Current_Value + (Ctxt, Get_Value_Wire (Val.Val.A_Obj)); return Build2_Extract (Ctxt, Res, Val.Val.A_Off.Net_Off, Val.Typ.W); else @@ -550,16 +396,51 @@ package body Synth.Vhdl_Context is end if; end; when Value_Const => - if Val.Val.C_Net = No_Net then - Val.Val.C_Net := Get_Net (Ctxt, (Val.Typ, Val.Val.C_Val)); - Locations.Set_Location (Get_Net_Parent (Val.Val.C_Net), - Get_Location (Val.Val.C_Loc)); - end if; - return Val.Val.C_Net; + declare + N : Net; + begin + N := To_Net (Val.Val.C_Net); + if N = No_Net then + N := Get_Net (Ctxt, (Val.Typ, Val.Val.C_Val)); + Val.Val.C_Net := To_Uns32 (N); + Locations.Set_Location (Get_Net_Parent (N), + Get_Location (Val.Val.C_Loc)); + end if; + return N; + end; when Value_Memory => return Get_Memtyp_Net (Ctxt, Get_Memtyp (Val)); when others => raise Internal_Error; end case; end Get_Net; + + function Is_Static_Val (Val : Value_Acc) return Boolean is + begin + case Val.Kind is + when Value_Memory => + return True; + when Value_Net + | Value_Signal => + return False; + when Value_Wire => + declare + W : constant Wire_Id := Get_Value_Wire (Val); + begin + if Get_Kind (W) = Wire_Variable then + return Is_Static_Wire (W); + else + -- A signal does not have static values. + return False; + end if; + end; + when Value_File => + return True; + when Value_Const => + return True; + when Value_Alias => + return Is_Static_Val (Val.A_Obj); + end case; + end Is_Static_Val; + end Synth.Vhdl_Context; diff --git a/src/synth/synth-vhdl_context.ads b/src/synth/synth-vhdl_context.ads index 2329c4c0d..df3e83d6a 100644 --- a/src/synth/synth-vhdl_context.ads +++ b/src/synth/synth-vhdl_context.ads @@ -18,52 +18,49 @@ with Types; use Types; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + with Netlists; use Netlists; with Netlists.Builders; use Netlists.Builders; -with Vhdl.Annotations; use Vhdl.Annotations; with Vhdl.Nodes; use Vhdl.Nodes; with Synth.Context; use Synth.Context; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; package Synth.Vhdl_Context is -- Values are stored into Synth_Instance, which is parallel to simulation -- Block_Instance_Type. - type Synth_Instance_Type (<>) is limited private; - type Synth_Instance_Acc is access Synth_Instance_Type; - - function Get_Instance_By_Scope - (Syn_Inst: Synth_Instance_Acc; Scope: Sim_Info_Acc) - return Synth_Instance_Acc; - - -- Create the first instance. - function Make_Base_Instance (Base : Base_Instance_Acc) - return Synth_Instance_Acc; + -- Create the root instance. + procedure Make_Base_Instance (Base : Base_Instance_Acc); -- Free the first instance. procedure Free_Base_Instance; - -- Create and free the corresponding synth instance. + -- Create a synth instance. + procedure Set_Extra (Inst : Synth_Instance_Acc; + Base : Base_Instance_Acc; + Name : Sname := No_Sname); + + procedure Set_Extra (Inst :Synth_Instance_Acc; + Parent : Synth_Instance_Acc; + Name : Sname := No_Sname); + function Make_Instance (Parent : Synth_Instance_Acc; Blk : Node; Name : Sname := No_Sname) return Synth_Instance_Acc; + procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc); + -- Only useful for subprograms: set the base (which can be different from -- the parent). Ideally it should be part of Make_Instance, but in most -- cases they are the same (except sometimes for subprograms). procedure Set_Instance_Base (Inst : Synth_Instance_Acc; Base : Synth_Instance_Acc); - procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc); - - function Is_Error (Inst : Synth_Instance_Acc) return Boolean; - pragma Inline (Is_Error); - - procedure Set_Error (Inst : Synth_Instance_Acc); function Get_Sname (Inst : Synth_Instance_Acc) return Sname; pragma Inline (Get_Sname); @@ -79,45 +76,12 @@ package Synth.Vhdl_Context is -- Start the definition of module M (using INST). procedure Set_Instance_Module (Inst : Synth_Instance_Acc; M : Module); - function Get_Instance_Const (Inst : Synth_Instance_Acc) return Boolean; - procedure Set_Instance_Const (Inst : Synth_Instance_Acc; Val : Boolean); - - -- Get the corresponding source for the scope of the instance. - function Get_Source_Scope (Inst : Synth_Instance_Acc) return Node; - - procedure Create_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); - - procedure Create_Package_Object (Syn_Inst : Synth_Instance_Acc; - Decl : Node; - Inst : Synth_Instance_Acc; - Is_Global : Boolean); - - procedure Create_Package_Interface (Syn_Inst : Synth_Instance_Acc; - Decl : Node; - Inst : Synth_Instance_Acc); - - procedure Create_Subtype_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Typ : Type_Acc); - - -- Force the value of DECL, without checking for elaboration order. - -- It is for deferred constants. - procedure Create_Object_Force - (Syn_Inst : Synth_Instance_Acc; Decl : Node; Vt : Valtyp); - - procedure Destroy_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node); - -- Build the value for object OBJ. -- KIND must be Wire_Variable or Wire_Signal. procedure Create_Wire_Object (Syn_Inst : Synth_Instance_Acc; Kind : Wire_Kind; Obj : Node); - -- Get the value of OBJ. - function Get_Value (Syn_Inst : Synth_Instance_Acc; Obj : Node) - return Valtyp; - -- Get a net from a scalar/vector value. This will automatically create -- a net for literals. function Get_Net (Ctxt : Context_Acc; Val : Valtyp) return Net; @@ -125,74 +89,29 @@ package Synth.Vhdl_Context is (Ctxt : Context_Acc; Val : Memtyp; Off : Uns32; Wd : Width) return Net; function Get_Memtyp_Net (Ctxt : Context_Acc; Val : Memtyp) return Net; - function Get_Package_Object - (Syn_Inst : Synth_Instance_Acc; Pkg : Node) return Synth_Instance_Acc; + -- Can also return true for nets and wires. + -- Use Get_Static_Discrete to get the value. + function Is_Static_Val (Val : Value_Acc) return Boolean; - -- Return the type for DECL (a subtype indication). - function Get_Subtype_Object - (Syn_Inst : Synth_Instance_Acc; Decl : Node) return Type_Acc; + function Get_Value_Net (Val : Value_Acc) return Net; + pragma Inline (Get_Value_Net); + procedure Set_Value_Net (Val : Value_Acc; N : Net); + pragma Inline (Set_Value_Net); + function Get_Value_Wire (Val : Value_Acc) return Wire_Id; + pragma Inline (Get_Value_Wire); + procedure Set_Value_Wire (Val : Value_Acc; W : Wire_Id); + pragma Inline (Set_Value_Wire); - -- Return the scope of the parent of BLK. Deals with architecture bodies. - function Get_Parent_Scope (Blk : Node) return Sim_Info_Acc; + -- Create a Value_Net. + function Create_Value_Net (N : Net; Ntype : Type_Acc) return Valtyp; - procedure Set_Uninstantiated_Scope - (Syn_Inst : Synth_Instance_Acc; Bod : Node); + -- Create a Value_Wire. For a bit wire, RNG must be null. + function Create_Value_Wire (W : Wire_Id; Wtype : Type_Acc) return Valtyp; private - type Obj_Kind is - ( - Obj_None, - Obj_Object, - Obj_Subtype, - Obj_Instance - ); - - type Obj_Type (Kind : Obj_Kind := Obj_None) is record - case Kind is - when Obj_None => - null; - when Obj_Object => - Obj : Valtyp; - when Obj_Subtype => - T_Typ : Type_Acc; - when Obj_Instance => - I_Inst : Synth_Instance_Acc; - end case; - end record; - - type Objects_Array is array (Object_Slot_Type range <>) of Obj_Type; - - type Synth_Instance_Type (Max_Objs : Object_Slot_Type) is limited record - Is_Const : Boolean; - - -- True if a fatal error has been detected that aborts the synthesis - -- of this instance. - Is_Error : Boolean; - + type Extra_Vhdl_Instance_Type is record Base : Base_Instance_Acc; -- Name prefix for declarations. Name : Sname; - - -- The corresponding info for this instance. - -- This is used for lookup. - Block_Scope : Sim_Info_Acc; - - -- The corresponding info the the uninstantiated specification of - -- an instantiated package. When an object is looked for from the - -- uninstantiated body, the scope of the uninstantiated specification - -- is used. And it is different from Block_Scope. - -- This is used for lookup of uninstantiated specification. - Uninst_Scope : Sim_Info_Acc; - - -- Instance of the parent scope. - Up_Block : Synth_Instance_Acc; - - -- Source construct corresponding to this instance/ - Source_Scope : Node; - - Elab_Objects : Object_Slot_Type; - - -- Instance for synthesis. - Objects : Objects_Array (1 .. Max_Objs); end record; end Synth.Vhdl_Context; diff --git a/src/synth/synth-vhdl_decls.adb b/src/synth/synth-vhdl_decls.adb index e2d130631..8b54c94bd 100644 --- a/src/synth/synth-vhdl_decls.adb +++ b/src/synth/synth-vhdl_decls.adb @@ -17,7 +17,6 @@ -- along with this program. If not, see . with Types; use Types; -with Mutils; use Mutils; with Std_Names; with Netlists.Builders; use Netlists.Builders; @@ -28,45 +27,49 @@ with Netlists.Gates; with Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Std_Package; -with Vhdl.Ieee.Std_Logic_1164; + +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Vhdl_Decls; use Elab.Vhdl_Decls; +with Elab.Vhdl_Files; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Vhdl_Stmts; with Synth.Source; use Synth.Source; with Synth.Errors; use Synth.Errors; -with Synth.Vhdl_Files; -with Synth.Values; use Synth.Values; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; package body Synth.Vhdl_Decls is - procedure Create_Var_Wire - (Syn_Inst : Synth_Instance_Acc; Decl : Iir; Init : Valtyp) + function Create_Var_Wire (Syn_Inst : Synth_Instance_Acc; + Decl : Node; + Kind : Wire_Kind; + Init : Valtyp) return Valtyp is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); - Vt : constant Valtyp := Get_Value (Syn_Inst, Decl); Value : Net; Ival : Net; W : Width; Name : Sname; + Wid : Wire_Id; begin - case Vt.Val.Kind is - when Value_Wire => - -- FIXME: get the width directly from the wire ? - W := Get_Type_Width (Vt.Typ); - Name := New_Sname_User (Get_Identifier (Decl), - Get_Sname (Syn_Inst)); - if Init /= No_Valtyp then - Ival := Get_Net (Ctxt, Init); - pragma Assert (Get_Width (Ival) = W); - Value := Build_Isignal (Ctxt, Name, Ival); - else - Value := Build_Signal (Ctxt, Name, W); - end if; - Set_Location (Value, Decl); - Set_Wire_Gate (Vt.Val.W, Value); - when others => - raise Internal_Error; - end case; + Wid := Alloc_Wire (Kind, (Decl, Init.Typ)); + + -- FIXME: get the width directly from the wire ? + W := Get_Type_Width (Init.Typ); + Name := New_Sname_User (Get_Identifier (Decl), + Get_Sname (Syn_Inst)); + if Init.Val /= null then + Ival := Get_Net (Ctxt, Init); + pragma Assert (Get_Width (Ival) = W); + Value := Build_Isignal (Ctxt, Name, Ival); + else + Value := Build_Signal (Ctxt, Name, W); + end if; + Set_Location (Value, Decl); + + Set_Wire_Gate (Wid, Value); + return Create_Value_Wire (Wid, Init.Typ); end Create_Var_Wire; function Type_To_Param_Type (Atype : Node) return Param_Type @@ -119,403 +122,6 @@ package body Synth.Vhdl_Decls is return Pv; end Memtyp_To_Pval; - procedure Synth_Subtype_Indication_If_Anonymous - (Syn_Inst : Synth_Instance_Acc; Atype : Node) is - begin - if Get_Type_Declarator (Atype) = Null_Node then - Synth_Subtype_Indication (Syn_Inst, Atype); - end if; - end Synth_Subtype_Indication_If_Anonymous; - - function Synth_Subtype_Indication_If_Anonymous - (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc is - begin - if Get_Type_Declarator (Atype) = Null_Node then - return Synth_Subtype_Indication (Syn_Inst, Atype); - else - return Get_Subtype_Object (Syn_Inst, Atype); - end if; - end Synth_Subtype_Indication_If_Anonymous; - - function Synth_Array_Type_Definition - (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc - is - El_Type : constant Node := Get_Element_Subtype (Def); - Ndims : constant Natural := Get_Nbr_Dimensions (Def); - El_Typ : Type_Acc; - Typ : Type_Acc; - begin - Synth_Subtype_Indication_If_Anonymous (Syn_Inst, El_Type); - El_Typ := Get_Subtype_Object (Syn_Inst, El_Type); - - if El_Typ.Kind in Type_Nets and then Ndims = 1 then - Typ := Create_Unbounded_Vector (El_Typ); - else - Typ := Create_Unbounded_Array (Dim_Type (Ndims), El_Typ); - end if; - return Typ; - end Synth_Array_Type_Definition; - - function Synth_Record_Type_Definition - (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc - is - El_List : constant Node_Flist := Get_Elements_Declaration_List (Def); - Rec_Els : Rec_El_Array_Acc; - El : Node; - El_Type : Node; - El_Typ : Type_Acc; - begin - Rec_Els := Create_Rec_El_Array - (Iir_Index32 (Get_Nbr_Elements (El_List))); - - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - El_Type := Get_Type (El); - El_Typ := Synth_Subtype_Indication_If_Anonymous (Syn_Inst, El_Type); - Rec_Els.E (Iir_Index32 (I + 1)).Typ := El_Typ; - end loop; - - if not Is_Fully_Constrained_Type (Def) then - return Create_Unbounded_Record (Rec_Els); - else - return Create_Record_Type (Rec_Els); - end if; - end Synth_Record_Type_Definition; - - function Synth_Access_Type_Definition - (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc - is - Des_Type : constant Node := Get_Designated_Type (Def); - Des_Typ : Type_Acc; - Typ : Type_Acc; - begin - Synth_Subtype_Indication_If_Anonymous (Syn_Inst, Des_Type); - Des_Typ := Get_Subtype_Object (Syn_Inst, Des_Type); - - Typ := Create_Access_Type (Des_Typ); - return Typ; - end Synth_Access_Type_Definition; - - function Synth_File_Type_Definition - (Syn_Inst : Synth_Instance_Acc; Def : Node) return Type_Acc - is - File_Type : constant Node := Get_Type (Get_File_Type_Mark (Def)); - File_Typ : Type_Acc; - Typ : Type_Acc; - Sig : String_Acc; - begin - File_Typ := Get_Subtype_Object (Syn_Inst, File_Type); - - if Get_Text_File_Flag (Def) - or else - Get_Kind (File_Type) in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Sig := null; - else - declare - Sig_Str : String (1 .. Get_File_Signature_Length (File_Type) + 2); - Off : Natural := Sig_Str'First; - begin - Get_File_Signature (File_Type, Sig_Str, Off); - Sig_Str (Off + 0) := '.'; - Sig_Str (Off + 1) := ASCII.NUL; - Sig := new String'(Sig_Str); - end; - end if; - - Typ := Create_File_Type (File_Typ); - Typ.File_Signature := Sig; - - return Typ; - end Synth_File_Type_Definition; - - function Scalar_Size_To_Size (Def : Node) return Size_Type is - begin - case Get_Scalar_Size (Def) is - when Scalar_8 => - return 1; - when Scalar_16 => - return 2; - when Scalar_32 => - return 4; - when Scalar_64 => - return 8; - end case; - end Scalar_Size_To_Size; - - procedure Synth_Type_Definition (Syn_Inst : Synth_Instance_Acc; Def : Node) - is - Typ : Type_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition => - if Def = Vhdl.Ieee.Std_Logic_1164.Std_Ulogic_Type - or else Def = Vhdl.Ieee.Std_Logic_1164.Std_Logic_Type - then - Typ := Logic_Type; - elsif Def = Vhdl.Std_Package.Boolean_Type_Definition then - Typ := Boolean_Type; - elsif Def = Vhdl.Std_Package.Bit_Type_Definition then - Typ := Bit_Type; - else - declare - Nbr_El : constant Natural := - Get_Nbr_Elements (Get_Enumeration_Literal_List (Def)); - Rng : Discrete_Range_Type; - W : Width; - begin - W := Uns32 (Clog2 (Uns64 (Nbr_El))); - Rng := (Dir => Dir_To, - Is_Signed => False, - Left => 0, - Right => Int64 (Nbr_El - 1)); - Typ := Create_Discrete_Type - (Rng, Scalar_Size_To_Size (Def), W); - end; - end if; - when Iir_Kind_Array_Type_Definition => - Typ := Synth_Array_Type_Definition (Syn_Inst, Def); - when Iir_Kind_Access_Type_Definition => - Typ := Synth_Access_Type_Definition (Syn_Inst, Def); - when Iir_Kind_File_Type_Definition => - Typ := Synth_File_Type_Definition (Syn_Inst, Def); - when Iir_Kind_Record_Type_Definition => - Typ := Synth_Record_Type_Definition (Syn_Inst, Def); - when Iir_Kind_Protected_Type_Declaration => - Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Def)); - when others => - Vhdl.Errors.Error_Kind ("synth_type_definition", Def); - end case; - if Typ /= null then - Create_Subtype_Object (Syn_Inst, Def, Typ); - end if; - end Synth_Type_Definition; - - procedure Synth_Anonymous_Type_Definition - (Syn_Inst : Synth_Instance_Acc; Def : Node; St : Node) - is - Typ : Type_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Physical_Type_Definition => - declare - Cst : constant Node := Get_Range_Constraint (St); - L, R : Int64; - Rng : Discrete_Range_Type; - W : Width; - begin - L := Get_Value (Get_Left_Limit (Cst)); - R := Get_Value (Get_Right_Limit (Cst)); - Rng := Build_Discrete_Range_Type (L, R, Get_Direction (Cst)); - W := Discrete_Range_Width (Rng); - Typ := Create_Discrete_Type - (Rng, Scalar_Size_To_Size (Def), W); - end; - when Iir_Kind_Floating_Type_Definition => - declare - Cst : constant Node := Get_Range_Constraint (St); - L, R : Fp64; - Rng : Float_Range_Type; - begin - L := Get_Fp_Value (Get_Left_Limit (Cst)); - R := Get_Fp_Value (Get_Right_Limit (Cst)); - Rng := (Get_Direction (Cst), L, R); - Typ := Create_Float_Type (Rng); - end; - when Iir_Kind_Array_Type_Definition => - Typ := Synth_Array_Type_Definition (Syn_Inst, Def); - when others => - Vhdl.Errors.Error_Kind ("synth_anonymous_type_definition", Def); - end case; - Create_Subtype_Object (Syn_Inst, Def, Typ); - end Synth_Anonymous_Type_Definition; - - function Synth_Discrete_Range_Constraint - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type - is - Res : Discrete_Range_Type; - begin - Synth_Discrete_Range (Syn_Inst, Rng, Res); - return Res; - end Synth_Discrete_Range_Constraint; - - function Synth_Float_Range_Constraint - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type is - begin - case Get_Kind (Rng) is - when Iir_Kind_Range_Expression => - -- FIXME: check range. - return Synth_Float_Range_Expression (Syn_Inst, Rng); - when others => - Vhdl.Errors.Error_Kind ("synth_float_range_constraint", Rng); - end case; - end Synth_Float_Range_Constraint; - - function Has_Element_Subtype_Indication (Atype : Node) return Boolean is - begin - return Get_Array_Element_Constraint (Atype) /= Null_Node - or else - (Get_Resolution_Indication (Atype) /= Null_Node - and then - (Get_Kind (Get_Resolution_Indication (Atype)) - = Iir_Kind_Array_Element_Resolution)); - end Has_Element_Subtype_Indication; - - function Synth_Array_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc - is - El_Type : constant Node := Get_Element_Subtype (Atype); - St_Indexes : constant Node_Flist := Get_Index_Subtype_List (Atype); - Ptype : Node; - St_El : Node; - Btyp : Type_Acc; - Etyp : Type_Acc; - Bnds : Bound_Array_Acc; - begin - -- VHDL08 - if Has_Element_Subtype_Indication (Atype) then - -- This subtype has created a new anonymous subtype for the - -- element. - Synth_Subtype_Indication (Syn_Inst, El_Type); - end if; - - if not Get_Index_Constraint_Flag (Atype) then - Ptype := Get_Type (Get_Subtype_Type_Mark (Atype)); - if Get_Element_Subtype (Ptype) = Get_Element_Subtype (Atype) then - -- That's an alias. - -- FIXME: maybe a resolution function was added? - -- FIXME: also handle resolution added in element subtype. - return Get_Subtype_Object (Syn_Inst, Ptype); - end if; - end if; - - Btyp := Get_Subtype_Object (Syn_Inst, Get_Base_Type (Atype)); - case Btyp.Kind is - when Type_Unbounded_Vector => - if Get_Index_Constraint_Flag (Atype) then - St_El := Get_Index_Type (St_Indexes, 0); - return Create_Vector_Type - (Synth_Bounds_From_Range (Syn_Inst, St_El), Btyp.Uvec_El); - else - -- An alias. - -- Handle vhdl08 definition of std_logic_vector from - -- std_ulogic_vector. - return Btyp; - end if; - when Type_Unbounded_Array => - -- FIXME: partially constrained arrays, subtype in indexes... - Etyp := Get_Subtype_Object (Syn_Inst, El_Type); - if Get_Index_Constraint_Flag (Atype) then - Bnds := Create_Bound_Array - (Dim_Type (Get_Nbr_Elements (St_Indexes))); - for I in Flist_First .. Flist_Last (St_Indexes) loop - St_El := Get_Index_Type (St_Indexes, I); - Bnds.D (Dim_Type (I + 1)) := - Synth_Bounds_From_Range (Syn_Inst, St_El); - end loop; - return Create_Array_Type (Bnds, Etyp); - else - raise Internal_Error; - end if; - when others => - raise Internal_Error; - end case; - end Synth_Array_Subtype_Indication; - - function Synth_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc is - begin - -- TODO: handle aliases directly. - case Get_Kind (Atype) is - when Iir_Kind_Array_Subtype_Definition => - return Synth_Array_Subtype_Indication (Syn_Inst, Atype); - when Iir_Kind_Record_Subtype_Definition => - return Synth_Record_Type_Definition (Syn_Inst, Atype); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - declare - Btype : constant Type_Acc := - Get_Subtype_Object (Syn_Inst, Get_Base_Type (Atype)); - Rng : Discrete_Range_Type; - W : Width; - begin - if Btype.Kind in Type_Nets then - -- A subtype of a bit/logic type is still a bit/logic. - -- FIXME: bounds. - return Btype; - else - Rng := Synth_Discrete_Range_Constraint - (Syn_Inst, Get_Range_Constraint (Atype)); - W := Discrete_Range_Width (Rng); - return Create_Discrete_Type (Rng, Btype.Sz, W); - end if; - end; - when Iir_Kind_Floating_Subtype_Definition => - declare - Rng : Float_Range_Type; - begin - Rng := Synth_Float_Range_Constraint - (Syn_Inst, Get_Range_Constraint (Atype)); - return Create_Float_Type (Rng); - end; - when others => - Vhdl.Errors.Error_Kind ("synth_subtype_indication", Atype); - end case; - end Synth_Subtype_Indication; - - procedure Synth_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node) - is - Typ : Type_Acc; - begin - Typ := Synth_Subtype_Indication (Syn_Inst, Atype); - Create_Subtype_Object (Syn_Inst, Atype, Typ); - end Synth_Subtype_Indication; - - function Get_Declaration_Type (Decl : Node) return Node - is - Ind : constant Node := Get_Subtype_Indication (Decl); - Atype : Node; - begin - if Get_Is_Ref (Decl) or else Ind = Null_Iir then - -- A secondary declaration in a list. - return Null_Node; - end if; - Atype := Ind; - loop - case Get_Kind (Atype) is - when Iir_Kinds_Denoting_Name => - Atype := Get_Named_Entity (Atype); - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration => - -- Type already declared, so already handled. - return Null_Node; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - return Atype; - when others => - Vhdl.Errors.Error_Kind ("get_declaration_type", Atype); - end case; - end loop; - end Get_Declaration_Type; - - procedure Synth_Declaration_Type - (Syn_Inst : Synth_Instance_Acc; Decl : Node) - is - Atype : constant Node := Get_Declaration_Type (Decl); - begin - if Atype = Null_Node then - return; - end if; - Synth_Subtype_Indication (Syn_Inst, Atype); - end Synth_Declaration_Type; - procedure Synth_Constant_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Node; Is_Subprg : Boolean; @@ -529,7 +135,7 @@ package body Synth.Vhdl_Decls is Cst : Valtyp; Obj_Type : Type_Acc; begin - Synth_Declaration_Type (Syn_Inst, Decl); + Elab_Declaration_Type (Syn_Inst, Decl); if Deferred_Decl = Null_Node or else Get_Deferred_Declaration_Flag (Decl) then @@ -616,7 +222,7 @@ package body Synth.Vhdl_Decls is | Iir_Kind_Interface_Signal_Declaration => V := Get_Value (Syn_Inst, Obj); pragma Assert (V.Val.Kind = Value_Wire); - Inst := Get_Net_Parent (Get_Wire_Gate (V.Val.W)); + Inst := Get_Net_Parent (Get_Wire_Gate (Get_Value_Wire (V.Val))); when Iir_Kind_Component_Instantiation_Statement => -- TODO return; @@ -667,59 +273,30 @@ package body Synth.Vhdl_Decls is Create_Object (Syn_Inst, Value, Val); -- Unshare (Val, Instance_Pool); - if not Get_Instance_Const (Syn_Inst) then - Synth_Attribute_Object (Syn_Inst, Value, Attr_Decl, Val); - end if; - Value := Get_Spec_Chain (Value); end loop; end Synth_Attribute_Specification; - procedure Synth_Subprogram_Declaration - (Syn_Inst : Synth_Instance_Acc; Subprg : Node) + procedure Synth_Concurrent_Attribute_Specification + (Syn_Inst : Synth_Instance_Acc; Spec : Node) is - Inter : Node; + Attr_Decl : constant Node := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + Value : Node; + Val : Valtyp; begin - if Is_Second_Subprogram_Specification (Subprg) then - -- Already handled. + if Get_Instance_Const (Syn_Inst) then return; end if; - Inter := Get_Interface_Declaration_Chain (Subprg); - while Inter /= Null_Node loop - Synth_Declaration_Type (Syn_Inst, Inter); - Inter := Get_Chain (Inter); - end loop; - end Synth_Subprogram_Declaration; - - procedure Synth_Convertible_Declarations (Syn_Inst : Synth_Instance_Acc) - is - use Vhdl.Std_Package; - begin - Create_Subtype_Object - (Syn_Inst, Convertible_Integer_Type_Definition, - Get_Subtype_Object (Syn_Inst, Universal_Integer_Type_Definition)); - Create_Subtype_Object - (Syn_Inst, Convertible_Real_Type_Definition, - Get_Subtype_Object (Syn_Inst, Universal_Real_Type_Definition)); - end Synth_Convertible_Declarations; + Value := Get_Attribute_Value_Spec_Chain (Spec); + while Value /= Null_Iir loop + Val := Get_Value (Syn_Inst, Value); + Synth_Attribute_Object (Syn_Inst, Value, Attr_Decl, Val); - function Create_Package_Instance (Parent_Inst : Synth_Instance_Acc; - Pkg : Node) - return Synth_Instance_Acc - is - Syn_Inst : Synth_Instance_Acc; - begin - Syn_Inst := Make_Instance (Parent_Inst, Pkg); - if Get_Kind (Get_Parent (Pkg)) = Iir_Kind_Design_Unit then - -- Global package. - Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, True); - else - -- Local package: check elaboration order. - Create_Package_Object (Parent_Inst, Pkg, Syn_Inst, False); - end if; - return Syn_Inst; - end Create_Package_Instance; + Value := Get_Spec_Chain (Value); + end loop; + end Synth_Concurrent_Attribute_Specification; procedure Synth_Package_Declaration (Parent_Inst : Synth_Instance_Acc; Pkg : Node) @@ -731,12 +308,10 @@ package body Synth.Vhdl_Decls is return; end if; - Syn_Inst := Create_Package_Instance (Parent_Inst, Pkg); + Syn_Inst := Get_Package_Object (Parent_Inst, Pkg); + Set_Extra (Syn_Inst, Parent_Inst, No_Sname); - Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Pkg)); - if Pkg = Vhdl.Std_Package.Standard_Package then - Synth_Convertible_Declarations (Syn_Inst); - end if; + Synth_Concurrent_Declarations (Syn_Inst, Get_Declaration_Chain (Pkg)); end Synth_Package_Declaration; procedure Synth_Package_Body @@ -751,97 +326,18 @@ package body Synth.Vhdl_Decls is Pkg_Inst := Get_Package_Object (Parent_Inst, Pkg); - Synth_Declarations (Pkg_Inst, Get_Declaration_Chain (Bod)); + Synth_Concurrent_Declarations (Pkg_Inst, Get_Declaration_Chain (Bod)); end Synth_Package_Body; - procedure Synth_Generics_Association (Sub_Inst : Synth_Instance_Acc; - Syn_Inst : Synth_Instance_Acc; - Inter_Chain : Node; - Assoc_Chain : Node) - is - Ctxt : constant Context_Acc := Get_Build (Syn_Inst); - Inter : Node; - Inter_Type : Type_Acc; - Assoc : Node; - Assoc_Inter : Node; - Actual : Node; - Val : Valtyp; - begin - Assoc := Assoc_Chain; - Assoc_Inter := Inter_Chain; - while Is_Valid (Assoc) loop - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is - when Iir_Kind_Interface_Constant_Declaration => - Synth_Declaration_Type (Sub_Inst, Inter); - Inter_Type := Get_Subtype_Object (Sub_Inst, Get_Type (Inter)); - - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_Open => - Actual := Get_Default_Value (Inter); - Val := Synth_Expression_With_Type - (Sub_Inst, Actual, Inter_Type); - when Iir_Kind_Association_Element_By_Expression => - Actual := Get_Actual (Assoc); - Val := Synth_Expression_With_Type - (Syn_Inst, Actual, Inter_Type); - when others => - raise Internal_Error; - end case; - - Val := Synth_Subtype_Conversion - (Ctxt, Val, Inter_Type, True, Assoc); - - if Val = No_Valtyp then - Set_Error (Sub_Inst); - elsif not Is_Static (Val.Val) then - Error_Msg_Synth - (+Assoc, "value of generic %i must be static", +Inter); - Val := No_Valtyp; - Set_Error (Sub_Inst); - end if; - - Create_Object (Sub_Inst, Inter, Val); - - when Iir_Kind_Interface_Package_Declaration => - declare - Actual : constant Iir := - Strip_Denoting_Name (Get_Actual (Assoc)); - Pkg_Inst : Synth_Instance_Acc; - begin - Pkg_Inst := Get_Package_Object (Sub_Inst, Actual); - Create_Package_Interface (Sub_Inst, Inter, Pkg_Inst); - end; - - when Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Quantity_Declaration - | Iir_Kind_Interface_Terminal_Declaration => - raise Internal_Error; - - when Iir_Kinds_Interface_Subprogram_Declaration - | Iir_Kind_Interface_Type_Declaration => - raise Internal_Error; - end case; - - Next_Association_Interface (Assoc, Assoc_Inter); - end loop; - end Synth_Generics_Association; - procedure Synth_Package_Instantiation (Parent_Inst : Synth_Instance_Acc; Pkg : Node) is Bod : constant Node := Get_Instance_Package_Body (Pkg); Sub_Inst : Synth_Instance_Acc; begin - Sub_Inst := Create_Package_Instance (Parent_Inst, Pkg); - - Synth_Generics_Association - (Sub_Inst, Parent_Inst, - Get_Generic_Chain (Pkg), Get_Generic_Map_Aspect_Chain (Pkg)); + Sub_Inst := Get_Package_Object (Parent_Inst, Pkg); - Synth_Declarations (Sub_Inst, Get_Declaration_Chain (Pkg)); + Synth_Concurrent_Declarations (Sub_Inst, Get_Declaration_Chain (Pkg)); if Bod /= Null_Node then -- Macro expanded package instantiation. @@ -855,7 +351,7 @@ package body Synth.Vhdl_Decls is Set_Uninstantiated_Scope (Sub_Inst, Uninst); -- Synth declarations of (optional) body. if Uninst_Bod /= Null_Node then - Synth_Declarations + Synth_Concurrent_Declarations (Sub_Inst, Get_Declaration_Chain (Uninst_Bod)); end if; end; @@ -870,10 +366,11 @@ package body Synth.Vhdl_Decls is Def : constant Node := Get_Default_Value (Decl); Decl_Type : constant Node := Get_Type (Decl); Init : Valtyp; + Val : Valtyp; Obj_Typ : Type_Acc; Wid : Wire_Id; begin - Synth_Declaration_Type (Syn_Inst, Decl); + Elab_Declaration_Type (Syn_Inst, Decl); if Get_Kind (Decl_Type) = Iir_Kind_Protected_Type_Declaration then Error_Msg_Synth (+Decl, "protected type variable is not synthesizable"); @@ -910,9 +407,9 @@ package body Synth.Vhdl_Decls is Init := Unshare (Init, Current_Pool); Create_Object (Syn_Inst, Decl, Init); else - Create_Wire_Object (Syn_Inst, Wire_Variable, Decl); - Create_Var_Wire (Syn_Inst, Decl, Init); - Wid := Get_Value (Syn_Inst, Decl).Val.W; + Val := Create_Var_Wire (Syn_Inst, Decl, Wire_Variable, Init); + Create_Object (Syn_Inst, Decl, Val); + Wid := Get_Value_Wire (Val.Val); if Is_Subprg then if Is_Static (Init.Val) then Phi_Assign_Static (Wid, Get_Memtyp (Init)); @@ -924,36 +421,39 @@ package body Synth.Vhdl_Decls is end if; end Synth_Variable_Declaration; + procedure Synth_Shared_Variable_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node) + is + Init : Valtyp; + Val : Valtyp; + begin + Init := Get_Value (Syn_Inst, Decl); + + Val := Create_Var_Wire (Syn_Inst, Decl, Wire_Variable, Init); + Mutate_Object (Syn_Inst, Decl, Val); + end Synth_Shared_Variable_Declaration; + procedure Synth_Signal_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Node) is - Ctxt : constant Context_Acc := Get_Build (Syn_Inst); - Def : constant Iir := Get_Default_Value (Decl); - -- Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Prev : Valtyp; Init : Valtyp; - Obj_Typ : Type_Acc; + Val : Valtyp; begin - Synth_Declaration_Type (Syn_Inst, Decl); if Get_Kind (Get_Parent (Decl)) = Iir_Kind_Package_Declaration then Error_Msg_Synth (+Decl, "signals in packages are not supported"); - -- Avoid elaboration error. - Create_Object (Syn_Inst, Decl, No_Valtyp); return; end if; - Create_Wire_Object (Syn_Inst, Wire_Signal, Decl); - if Is_Valid (Def) then - Obj_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Decl)); - Init := Synth_Expression_With_Type (Syn_Inst, Def, Obj_Typ); - Init := Synth_Subtype_Conversion (Ctxt, Init, Obj_Typ, False, Decl); - if not Is_Static (Init.Val) then - Error_Msg_Synth (+Decl, "signals cannot be used in default value " - & "of a signal"); - end if; + Prev := Get_Value (Syn_Inst, Decl); + if Prev.Val.Init = null then + Init := (Prev.Typ, null); else - Init := No_Valtyp; + Init := (Prev.Typ, Prev.Val.Init); end if; - Create_Var_Wire (Syn_Inst, Decl, Init); + + Val := Create_Var_Wire (Syn_Inst, Decl, Wire_Signal, Init); + Replace_Signal (Syn_Inst, Decl, Val); end Synth_Signal_Declaration; procedure Synth_Object_Alias_Declaration @@ -983,7 +483,8 @@ package body Synth.Vhdl_Decls is -- Object is a net if it is not writable. Extract the -- bits for the alias. Res := Create_Value_Net - (Build2_Extract (Ctxt, Base.Val.N, Off.Net_Off, Typ.W), + (Build2_Extract (Ctxt, + Get_Value_Net (Base.Val), Off.Net_Off, Typ.W), Typ); else Res := Create_Value_Alias (Base, Off, Typ); @@ -994,6 +495,36 @@ package body Synth.Vhdl_Decls is Create_Object (Syn_Inst, Decl, Res); end Synth_Object_Alias_Declaration; + procedure Synth_Concurrent_Object_Alias_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) + is + Val : Valtyp; + Aval : Valtyp; + Obj : Value_Acc; + Base : Node; + begin + Val := Get_Value (Syn_Inst, Decl); + pragma Assert (Val.Val.Kind = Value_Alias); + Obj := Val.Val.A_Obj; + if Obj.Kind = Value_Signal then + -- A signal must have been changed to a wire or a net, but the + -- aliases have not been updated. Update here. + Base := Get_Base_Name (Get_Name (Decl)); + Aval := Synth_Expression (Syn_Inst, Base); + + if Aval.Val.Kind = Value_Net then + -- Object is a net if it is not writable. Extract the + -- bits for the alias. + Aval := Create_Value_Net + (Build2_Extract (Get_Build (Syn_Inst), Get_Value_Net (Aval.Val), + Val.Val.A_Off.Net_Off, Val.Typ.W), + Val.Typ); + Val.Val.A_Off := (0, 0); + end if; + Val.Val.A_Obj := Aval.Val; + end if; + end Synth_Concurrent_Object_Alias_Declaration; + procedure Synth_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Node; Is_Subprg : Boolean; @@ -1004,8 +535,15 @@ package body Synth.Vhdl_Decls is Synth_Variable_Declaration (Syn_Inst, Decl, Is_Subprg); when Iir_Kind_Interface_Variable_Declaration => -- Ignore default value. - Create_Wire_Object (Syn_Inst, Wire_Variable, Decl); - Create_Var_Wire (Syn_Inst, Decl, No_Valtyp); + declare + Val : Valtyp; + Obj_Typ : Type_Acc; + begin + Obj_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Decl)); + Val := Create_Var_Wire + (Syn_Inst, Decl, Wire_Variable, (Obj_Typ, null)); + Create_Object (Syn_Inst, Decl, Val); + end; when Iir_Kind_Constant_Declaration => Synth_Constant_Declaration (Syn_Inst, Decl, Is_Subprg, Last_Type); when Iir_Kind_Signal_Declaration => @@ -1015,7 +553,7 @@ package body Synth.Vhdl_Decls is Synth_Object_Alias_Declaration (Syn_Inst, Decl); when Iir_Kind_Procedure_Declaration | Iir_Kind_Function_Declaration => - Synth_Subprogram_Declaration (Syn_Inst, Decl); + Elab_Subprogram_Declaration (Syn_Inst, Decl); when Iir_Kind_Procedure_Body | Iir_Kind_Function_Body => null; @@ -1028,13 +566,13 @@ package body Synth.Vhdl_Decls is when Iir_Kind_Attribute_Specification => Synth_Attribute_Specification (Syn_Inst, Decl); when Iir_Kind_Type_Declaration => - Synth_Type_Definition (Syn_Inst, Get_Type_Definition (Decl)); + Elab_Type_Definition (Syn_Inst, Get_Type_Definition (Decl)); when Iir_Kind_Anonymous_Type_Declaration => - Synth_Anonymous_Type_Definition + Elab_Anonymous_Type_Definition (Syn_Inst, Get_Type_Definition (Decl), Get_Subtype_Definition (Decl)); when Iir_Kind_Subtype_Declaration => - Synth_Declaration_Type (Syn_Inst, Decl); + Elab_Declaration_Type (Syn_Inst, Decl); when Iir_Kind_Component_Declaration => null; when Iir_Kind_File_Declaration => @@ -1043,7 +581,7 @@ package body Synth.Vhdl_Decls is Res : Valtyp; Obj_Typ : Type_Acc; begin - F := Synth.Vhdl_Files.Elaborate_File_Declaration + F := Elab.Vhdl_Files.Elaborate_File_Declaration (Syn_Inst, Decl); Obj_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Decl)); Res := Create_Value_File (Obj_Typ, F); @@ -1067,7 +605,7 @@ package body Synth.Vhdl_Decls is end Synth_Declaration; procedure Synth_Declarations (Syn_Inst : Synth_Instance_Acc; - Decls : Iir; + Decls : Node; Is_Subprg : Boolean := False) is Decl : Node; @@ -1093,6 +631,7 @@ package body Synth.Vhdl_Decls is Gate : Instance; Drv : Net; Def_Val : Net; + W : Wire_Id; begin Vt := Get_Value (Syn_Inst, Decl); if Vt = No_Valtyp then @@ -1105,9 +644,11 @@ package body Synth.Vhdl_Decls is return; end if; - Finalize_Assignment (Get_Build (Syn_Inst), Vt.Val.W); + W := Get_Value_Wire (Vt.Val); + + Finalize_Assignment (Get_Build (Syn_Inst), W); - Gate_Net := Get_Wire_Gate (Vt.Val.W); + Gate_Net := Get_Wire_Gate (W); Gate := Get_Net_Parent (Gate_Net); case Get_Id (Gate) is when Id_Signal @@ -1147,7 +688,7 @@ package body Synth.Vhdl_Decls is Connect (Get_Input (Gate, 0), Def_Val); end if; - Free_Wire (Vt.Val.W); + Free_Wire (W); end Finalize_Signal; procedure Finalize_Declaration @@ -1203,10 +744,10 @@ package body Synth.Vhdl_Decls is end Finalize_Declaration; procedure Finalize_Declarations (Syn_Inst : Synth_Instance_Acc; - Decls : Iir; + Decls : Node; Is_Subprg : Boolean := False) is - Decl : Iir; + Decl : Node; begin Decl := Decls; while Is_Valid (Decl) loop @@ -1215,4 +756,50 @@ package body Synth.Vhdl_Decls is Decl := Get_Chain (Decl); end loop; end Finalize_Declarations; + + procedure Synth_Concurrent_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration => + Synth_Signal_Declaration (Syn_Inst, Decl); + when Iir_Kind_Variable_Declaration => + Synth_Shared_Variable_Declaration (Syn_Inst, Decl); + when Iir_Kind_Constant_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Procedure_Body + | Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Configuration_Specification + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Use_Clause => + -- Fully handled during elaboration. + null; + when Iir_Kind_Object_Alias_Declaration => + Synth_Concurrent_Object_Alias_Declaration (Syn_Inst, Decl); + when Iir_Kind_Attribute_Specification => + Synth_Concurrent_Attribute_Specification (Syn_Inst, Decl); + when others => + Vhdl.Errors.Error_Kind ("synth_concurrent_declaration", Decl); + end case; + end Synth_Concurrent_Declaration; + + procedure Synth_Concurrent_Declarations (Syn_Inst : Synth_Instance_Acc; + Decls : Node) + is + Decl : Node; + begin + Decl := Decls; + while Decl /= Null_Node loop + Synth_Concurrent_Declaration (Syn_Inst, Decl); + Decl := Get_Chain (Decl); + end loop; + end Synth_Concurrent_Declarations; end Synth.Vhdl_Decls; diff --git a/src/synth/synth-vhdl_decls.ads b/src/synth/synth-vhdl_decls.ads index fa1569430..5ad59853e 100644 --- a/src/synth/synth-vhdl_decls.ads +++ b/src/synth/synth-vhdl_decls.ads @@ -18,9 +18,10 @@ with Vhdl.Nodes; use Vhdl.Nodes; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; + with Netlists; use Netlists; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; -with Synth.Objtypes; use Synth.Objtypes; package Synth.Vhdl_Decls is -- Return the Param_Type for ATYPE. @@ -29,23 +30,7 @@ package Synth.Vhdl_Decls is -- Convert MT to a Pval. function Memtyp_To_Pval (Mt : Memtyp) return Pval; - -- Get the type of DECL iff it is standalone (not an already existing - -- subtype). - function Get_Declaration_Type (Decl : Node) return Node; - - -- True if the element subtype indication of ATYPE needs to be created. - function Has_Element_Subtype_Indication (Atype : Node) return Boolean; - - function Synth_Array_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc; - - procedure Synth_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node); - function Synth_Subtype_Indication - (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc; - - -- Elaborate the type of DECL. - procedure Synth_Declaration_Type + procedure Synth_Object_Alias_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Node); procedure Synth_Declaration (Syn_Inst : Synth_Instance_Acc; @@ -54,14 +39,19 @@ package Synth.Vhdl_Decls is Last_Type : in out Node); procedure Synth_Declarations (Syn_Inst : Synth_Instance_Acc; - Decls : Iir; + Decls : Node; Is_Subprg : Boolean := False); + procedure Synth_Concurrent_Declaration (Syn_Inst : Synth_Instance_Acc; + Decl : Node); + procedure Synth_Concurrent_Declarations (Syn_Inst : Synth_Instance_Acc; + Decls : Node); + procedure Finalize_Declaration (Syn_Inst : Synth_Instance_Acc; - Decl : Iir; + Decl : Node; Is_Subprg : Boolean); procedure Finalize_Declarations (Syn_Inst : Synth_Instance_Acc; - Decls : Iir; + Decls : Node; Is_Subprg : Boolean := False); procedure Synth_Package_Declaration @@ -69,11 +59,6 @@ package Synth.Vhdl_Decls is procedure Synth_Package_Body (Parent_Inst : Synth_Instance_Acc; Pkg : Node; Bod : Node); - procedure Synth_Generics_Association (Sub_Inst : Synth_Instance_Acc; - Syn_Inst : Synth_Instance_Acc; - Inter_Chain : Node; - Assoc_Chain : Node); - procedure Synth_Package_Instantiation (Parent_Inst : Synth_Instance_Acc; Pkg : Node); end Synth.Vhdl_Decls; diff --git a/src/synth/synth-vhdl_environment.ads b/src/synth/synth-vhdl_environment.ads index e9bf6129f..1a65b2a07 100644 --- a/src/synth/synth-vhdl_environment.ads +++ b/src/synth/synth-vhdl_environment.ads @@ -23,10 +23,10 @@ with Netlists.Builders; with Vhdl.Nodes; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; + with Synth.Environment; with Synth.Environment.Debug; -with Synth.Objtypes; use Synth.Objtypes; --- with Synth_Vhdl.Context; package Synth.Vhdl_Environment is @@ -52,7 +52,7 @@ package Synth.Vhdl_Environment is package Env is new Synth.Environment (Decl_Type => Decl_Type, - Static_Type => Standard.Synth.Objtypes.Memtyp, + Static_Type => Elab.Vhdl_Objtypes.Memtyp, Get_Width => Get_Bitwidth, Is_Equal => Is_Equal, Static_To_Net => Memtyp_To_Net, diff --git a/src/synth/synth-vhdl_expr.adb b/src/synth/synth-vhdl_expr.adb index 1b0030b2c..2717d5eec 100644 --- a/src/synth/synth-vhdl_expr.adb +++ b/src/synth/synth-vhdl_expr.adb @@ -39,15 +39,17 @@ with Netlists.Folds; use Netlists.Folds; with Netlists.Utils; use Netlists.Utils; with Netlists.Locations; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Heap; use Elab.Vhdl_Heap; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Debugger; + with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Environment; -with Synth.Vhdl_Decls; with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; with Synth.Vhdl_Oper; use Synth.Vhdl_Oper; -with Synth.Vhdl_Heap; use Synth.Vhdl_Heap; -with Synth.Debugger; with Synth.Vhdl_Aggr; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Grt.Types; with Grt.To_Strings; @@ -67,7 +69,8 @@ package body Synth.Vhdl_Expr is when Value_Const => return Get_Memtyp (V); when Value_Wire => - return Synth.Vhdl_Environment.Env.Get_Static_Wire (V.Val.W); + return Synth.Vhdl_Environment.Env.Get_Static_Wire + (Get_Value_Wire (V.Val)); when Value_Alias => declare Res : Memtyp; @@ -89,7 +92,8 @@ package body Synth.Vhdl_Expr is return Read_Discrete (Get_Memtyp (V)); when Value_Wire => return Read_Discrete - (Synth.Vhdl_Environment.Env.Get_Static_Wire (V.Val.W)); + (Synth.Vhdl_Environment.Env.Get_Static_Wire + (Get_Value_Wire (V.Val))); when others => raise Internal_Error; end case; @@ -107,15 +111,19 @@ package body Synth.Vhdl_Expr is | Value_Memory => return Read_Discrete (Get_Memtyp (V)) >= 0; when Value_Net => - N := V.Val.N; + N := Get_Value_Net (V.Val); when Value_Wire => - if Get_Kind (V.Val.W) = Wire_Variable - and then Is_Static_Wire (V.Val.W) - then - return Read_Discrete (Get_Static_Wire (V.Val.W)) >= 0; - else - return False; - end if; + declare + W : constant Wire_Id := Get_Value_Wire (V.Val); + begin + if Get_Kind (W) = Wire_Variable + and then Is_Static_Wire (W) + then + return Read_Discrete (Get_Static_Wire (W)) >= 0; + else + return False; + end if; + end; when others => raise Internal_Error; end case; @@ -429,206 +437,6 @@ package body Synth.Vhdl_Expr is N := Arr (Arr'First); end Concat_Array; - function Build_Discrete_Range_Type - (L : Int64; R : Int64; Dir : Direction_Type) return Discrete_Range_Type is - begin - return (Dir => Dir, - Left => L, - Right => R, - Is_Signed => L < 0 or R < 0); - end Build_Discrete_Range_Type; - - function Synth_Discrete_Range_Expression - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type - is - L, R : Valtyp; - Lval, Rval : Int64; - begin - -- Static values. - L := Synth_Expression_With_Basetype (Syn_Inst, Get_Left_Limit (Rng)); - R := Synth_Expression_With_Basetype (Syn_Inst, Get_Right_Limit (Rng)); - Strip_Const (L); - Strip_Const (R); - - if not (Is_Static (L.Val) and Is_Static (R.Val)) then - Error_Msg_Synth (+Rng, "limits of range are not constant"); - Set_Error (Syn_Inst); - return (Dir => Get_Direction (Rng), - Left => 0, - Right => 0, - Is_Signed => False); - end if; - - Lval := Read_Discrete (L); - Rval := Read_Discrete (R); - return Build_Discrete_Range_Type (Lval, Rval, Get_Direction (Rng)); - end Synth_Discrete_Range_Expression; - - function Synth_Float_Range_Expression - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type - is - L, R : Valtyp; - begin - -- Static values (so no enable). - L := Synth_Expression (Syn_Inst, Get_Left_Limit (Rng)); - R := Synth_Expression (Syn_Inst, Get_Right_Limit (Rng)); - return (Get_Direction (Rng), Read_Fp64 (L), Read_Fp64 (R)); - end Synth_Float_Range_Expression; - - -- Return the type of EXPR without evaluating it. - function Synth_Type_Of_Object (Syn_Inst : Synth_Instance_Acc; Expr : Node) - return Type_Acc is - begin - case Get_Kind (Expr) is - when Iir_Kinds_Object_Declaration => - declare - Val : constant Valtyp := Get_Value (Syn_Inst, Expr); - begin - return Val.Typ; - end; - when Iir_Kind_Simple_Name => - return Synth_Type_Of_Object (Syn_Inst, Get_Named_Entity (Expr)); - when Iir_Kind_Slice_Name => - declare - Pfx_Typ : Type_Acc; - Pfx_Bnd : Bound_Type; - El_Typ : Type_Acc; - Res_Bnd : Bound_Type; - Sl_Voff : Net; - Sl_Off : Value_Offsets; - begin - Pfx_Typ := Synth_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); - Get_Onedimensional_Array_Bounds (Pfx_Typ, Pfx_Bnd, El_Typ); - Synth_Slice_Suffix (Syn_Inst, Expr, Pfx_Bnd, El_Typ, - Res_Bnd, Sl_Voff, Sl_Off); - - if Sl_Voff /= No_Net then - raise Internal_Error; - end if; - return Create_Onedimensional_Array_Subtype (Pfx_Typ, Res_Bnd); - end; - when Iir_Kind_Indexed_Name => - declare - Pfx_Typ : Type_Acc; - begin - Pfx_Typ := Synth_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); - return Get_Array_Element (Pfx_Typ); - end; - when Iir_Kind_Selected_Element => - declare - Idx : constant Iir_Index32 := - Get_Element_Position (Get_Named_Entity (Expr)); - Pfx_Typ : Type_Acc; - begin - Pfx_Typ := Synth_Type_Of_Object (Syn_Inst, Get_Prefix (Expr)); - return Pfx_Typ.Rec.E (Idx + 1).Typ; - end; - - when Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference => - declare - Val : Valtyp; - Res : Valtyp; - begin - -- Maybe do not dereference it if its type is known ? - Val := Synth_Expression (Syn_Inst, Get_Prefix (Expr)); - Res := Vhdl_Heap.Synth_Dereference (Read_Access (Val)); - return Res.Typ; - end; - - when Iir_Kind_String_Literal8 => - -- TODO: the value should be computed (once) and its type - -- returned. - return Synth.Vhdl_Decls.Synth_Subtype_Indication - (Syn_Inst, Get_Type (Expr)); - - when others => - Vhdl.Errors.Error_Kind ("synth_type_of_object", Expr); - end case; - return null; - end Synth_Type_Of_Object; - - function Synth_Array_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) - return Bound_Type - is - Prefix_Name : constant Iir := Get_Prefix (Attr); - Prefix : constant Iir := Strip_Denoting_Name (Prefix_Name); - Dim : constant Natural := - Vhdl.Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); - Typ : Type_Acc; - Val : Valtyp; - begin - -- Prefix is an array object or an array subtype. - if Get_Kind (Prefix) = Iir_Kind_Subtype_Declaration then - -- TODO: does this cover all the cases ? - Typ := Get_Subtype_Object (Syn_Inst, Get_Subtype_Indication (Prefix)); - else - Val := Synth_Expression_With_Basetype (Syn_Inst, Prefix_Name); - Typ := Val.Typ; - end if; - - return Get_Array_Bound (Typ, Dim_Type (Dim)); - end Synth_Array_Attribute; - - procedure Synth_Discrete_Range (Syn_Inst : Synth_Instance_Acc; - Bound : Node; - Rng : out Discrete_Range_Type) is - begin - case Get_Kind (Bound) is - when Iir_Kind_Range_Expression => - Rng := Synth_Discrete_Range_Expression (Syn_Inst, Bound); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - if Get_Type_Declarator (Bound) /= Null_Node then - declare - Typ : Type_Acc; - begin - -- This is a named subtype, so it has been evaluated. - Typ := Get_Subtype_Object (Syn_Inst, Bound); - Rng := Typ.Drange; - end; - else - Synth_Discrete_Range - (Syn_Inst, Get_Range_Constraint (Bound), Rng); - end if; - when Iir_Kind_Range_Array_Attribute => - declare - B : Bound_Type; - begin - B := Synth_Array_Attribute (Syn_Inst, Bound); - Rng := Build_Discrete_Range_Type - (Int64 (B.Left), Int64 (B.Right), B.Dir); - end; - when Iir_Kind_Reverse_Range_Array_Attribute => - declare - B : Bound_Type; - T : Int32; - begin - B := Synth_Array_Attribute (Syn_Inst, Bound); - -- Reverse - case B.Dir is - when Dir_To => - B.Dir := Dir_Downto; - when Dir_Downto => - B.Dir := Dir_To; - end case; - T := B.Right; - B.Right := B.Left; - B.Left := T; - - Rng := Build_Discrete_Range_Type - (Int64 (B.Left), Int64 (B.Right), B.Dir); - end; - when Iir_Kinds_Denoting_Name => - -- A discrete subtype name. - Synth_Discrete_Range - (Syn_Inst, Get_Subtype_Indication (Get_Named_Entity (Bound)), - Rng); - when others => - Error_Kind ("synth_discrete_range", Bound); - end case; - end Synth_Discrete_Range; - function Synth_Array_Bounds (Syn_Inst : Synth_Instance_Acc; Atype : Node; Dim : Dim_Type) return Bound_Type @@ -660,17 +468,6 @@ package body Synth.Vhdl_Expr is end if; end Synth_Array_Bounds; - function Synth_Bounds_From_Range (Syn_Inst : Synth_Instance_Acc; - Atype : Node) return Bound_Type - is - Rng : Discrete_Range_Type; - begin - Synth_Discrete_Range (Syn_Inst, Atype, Rng); - return (Dir => Rng.Dir, - Left => Int32 (Rng.Left), Right => Int32 (Rng.Right), - Len => Get_Range_Length (Rng)); - end Synth_Bounds_From_Range; - function Synth_Bounds_From_Length (Atype : Node; Len : Int32) return Bound_Type is @@ -737,9 +534,9 @@ package body Synth.Vhdl_Expr is begin case Val.Val.Kind is when Value_Wire => - return Create_Value_Wire (Val.Val.W, Ntype); + return Create_Value_Wire (Get_Value_Wire (Val.Val), Ntype); when Value_Net => - return Create_Value_Net (Val.Val.N, Ntype); + return Create_Value_Net (Get_Value_Net (Val.Val), Ntype); when Value_Alias => return Create_Value_Alias ((Val.Val.A_Typ, Val.Val.A_Obj), Val.Val.A_Off, Ntype); @@ -884,6 +681,18 @@ package body Synth.Vhdl_Expr is end case; end Synth_Subtype_Conversion; + function Synth_Subtype_Conversion (Syn_Inst : Synth_Instance_Acc; + Vt : Valtyp; + Dtype : Type_Acc; + Bounds : Boolean; + Loc : Source.Syn_Src) + return Valtyp + is + Ctxt : constant Context_Acc := Get_Build (Syn_Inst); + begin + return Synth_Subtype_Conversion (Ctxt, Vt, Dtype, Bounds, Loc); + end Synth_Subtype_Conversion; + function Synth_Value_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node) return Valtyp is @@ -1076,7 +885,7 @@ package body Synth.Vhdl_Expr is Val : Valtyp; begin Val := Synth_Expression (Syn_Inst, Get_Prefix (Name)); - return Vhdl_Heap.Synth_Dereference (Read_Access (Val)); + return Elab.Vhdl_Heap.Synth_Dereference (Read_Access (Val)); end; when others => Error_Kind ("synth_name", Name); @@ -1093,7 +902,7 @@ package body Synth.Vhdl_Expr is begin if not In_Bounds (Bnd, Int32 (Idx)) then Error_Msg_Synth (+Loc, "index not within bounds"); - Synth.Debugger.Debug_Error (Syn_Inst, Loc); + Elab.Debugger.Debug_Error (Syn_Inst, Loc); return (0, 0); end if; @@ -1522,7 +1331,7 @@ package body Synth.Vhdl_Expr is or else not In_Bounds (Pfx_Bnd, Int32 (R)) then Error_Msg_Synth (+Name, "index not within bounds"); - Synth.Debugger.Debug_Error (Syn_Inst, Expr); + Elab.Debugger.Debug_Error (Syn_Inst, Expr); Off := (0, 0); return; end if; @@ -2247,7 +2056,7 @@ package body Synth.Vhdl_Expr is and then Get_Static_Discrete (Left) = Val then -- Short-circuit when the left operand determines the result. - return Create_Value_Discrete (Val, Boolean_Type); + return Create_Value_Discrete (Val, Typ); end if; Strip_Const (Left); @@ -2262,21 +2071,21 @@ package body Synth.Vhdl_Expr is and then Get_Static_Discrete (Right) = Val then -- If the right operand can determine the result, return it. - return Create_Value_Discrete (Val, Boolean_Type); + return Create_Value_Discrete (Val, Typ); end if; -- Return a static value if both operands are static. -- Note: we know the value of left if it is not constant. if Is_Static_Val (Left.Val) and then Is_Static_Val (Right.Val) then Val := Get_Static_Discrete (Right); - return Create_Value_Discrete (Val, Boolean_Type); + return Create_Value_Discrete (Val, Typ); end if; -- Non-static result. N := Build_Dyadic (Ctxt, Id, Get_Net (Ctxt, Left), Get_Net (Ctxt, Right)); Set_Location (N, Expr); - return Create_Value_Net (N, Boolean_Type); + return Create_Value_Net (N, Typ); end Synth_Short_Circuit; function Synth_Expression_With_Type (Syn_Inst : Synth_Instance_Acc; @@ -2353,13 +2162,16 @@ package body Synth.Vhdl_Expr is | Iir_Kind_Selected_Name | Iir_Kind_Interface_Signal_Declaration -- For PSL. | Iir_Kind_Signal_Declaration -- For PSL. + | Iir_Kind_Object_Alias_Declaration | Iir_Kind_Implicit_Dereference | Iir_Kind_Dereference => declare Res : Valtyp; begin Res := Synth_Name (Syn_Inst, Expr); - if Res.Typ.W = 0 and then Res.Val.Kind /= Value_Memory then + if Res.Typ /= null + and then Res.Typ.W = 0 and then Res.Val.Kind /= Value_Memory + then -- This is a null object. As nothing can be done about it, -- returns 0. return Create_Value_Memtyp (Create_Memory_Zero (Res.Typ)); @@ -2565,7 +2377,7 @@ package body Synth.Vhdl_Expr is T : Type_Acc; Acc : Heap_Index; begin - T := Synth.Vhdl_Decls.Synth_Subtype_Indication + T := Synth_Subtype_Indication (Syn_Inst, Get_Subtype_Indication (Expr)); Acc := Allocate_By_Type (T); return Create_Value_Access (Acc, Expr_Type); diff --git a/src/synth/synth-vhdl_expr.ads b/src/synth/synth-vhdl_expr.ads index c6726732e..7081aef95 100644 --- a/src/synth/synth-vhdl_expr.ads +++ b/src/synth/synth-vhdl_expr.ads @@ -23,13 +23,14 @@ with Types; use Types; with PSL.Types; with Vhdl.Nodes; use Vhdl.Nodes; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + with Netlists; use Netlists; with Netlists.Builders; use Netlists.Builders; with Synth.Source; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; package Synth.Vhdl_Expr is -- Perform a subtype conversion. Check constraints. @@ -40,6 +41,13 @@ package Synth.Vhdl_Expr is Loc : Source.Syn_Src) return Valtyp; + function Synth_Subtype_Conversion (Syn_Inst : Synth_Instance_Acc; + Vt : Valtyp; + Dtype : Type_Acc; + Bounds : Boolean; + Loc : Source.Syn_Src) + return Valtyp; + -- For a static value V, return the value. function Get_Static_Discrete (V : Valtyp) return Int64; @@ -93,24 +101,10 @@ package Synth.Vhdl_Expr is function Synth_PSL_Expression (Syn_Inst : Synth_Instance_Acc; Expr : PSL.Types.PSL_Node) return Net; - function Synth_Bounds_From_Range (Syn_Inst : Synth_Instance_Acc; - Atype : Node) return Bound_Type; - function Synth_Array_Bounds (Syn_Inst : Synth_Instance_Acc; Atype : Node; Dim : Dim_Type) return Bound_Type; - function Build_Discrete_Range_Type - (L : Int64; R : Int64; Dir : Direction_Type) return Discrete_Range_Type; - function Synth_Discrete_Range_Expression - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Discrete_Range_Type; - function Synth_Float_Range_Expression - (Syn_Inst : Synth_Instance_Acc; Rng : Node) return Float_Range_Type; - - procedure Synth_Discrete_Range (Syn_Inst : Synth_Instance_Acc; - Bound : Node; - Rng : out Discrete_Range_Type); - procedure Synth_Slice_Suffix (Syn_Inst : Synth_Instance_Acc; Name : Node; Pfx_Bnd : Bound_Type; @@ -127,13 +121,7 @@ package Synth.Vhdl_Expr is Voff : out Net; Off : out Value_Offsets); - -- Return the type of EXPR (an object) without evaluating it (except when - -- needed, like bounds of a slice). - function Synth_Type_Of_Object (Syn_Inst : Synth_Instance_Acc; Expr : Node) - return Type_Acc; - -- Conversion to logic vector. - type Digit_Index is new Natural; type Logvec_Array is array (Digit_Index range <>) of Logic_32; type Logvec_Array_Acc is access Logvec_Array; diff --git a/src/synth/synth-vhdl_files.adb b/src/synth/synth-vhdl_files.adb deleted file mode 100644 index 2300ff9f9..000000000 --- a/src/synth/synth-vhdl_files.adb +++ /dev/null @@ -1,416 +0,0 @@ --- Create declarations for 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 Files_Map; -with Name_Table; - -with Grt.Types; use Grt.Types; -with Grt.Files_Operations; use Grt.Files_Operations; -with Grt.Stdio; - -with Synth.Memtype; use Synth.Memtype; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; -with Synth.Errors; use Synth.Errors; - -package body Synth.Vhdl_Files is - - -- Variables to store the search path. - Current_Unit : Node := Null_Node; - Current_Pfx_Len : Integer := -1; - Current_Pfx_Id : Name_Id := No_Name_Id; - - -- Representation of file name compatible with C (so NUL terminated). - subtype C_File_Name is String (1 .. 1025); - - procedure File_Error (Loc : Node; Status : Op_Status); - pragma No_Return (File_Error); - - procedure File_Error (Loc : Node; Status : Op_Status) is - begin - pragma Assert (Status /= Op_Ok); - Error_Msg_Synth (+Loc, "file operation failed"); - raise File_Execution_Error; - end File_Error; - - -- VAL represents a string, so an array of characters. - procedure Convert_String (Val : Valtyp; Res : out String) - is - Vtyp : constant Type_Acc := Val.Typ; - Vlen : constant Uns32 := Vtyp.Abounds.D (1).Len; - begin - pragma Assert (Vtyp.Kind = Type_Array); - pragma Assert (Vtyp.Arr_El.Kind = Type_Discrete); - pragma Assert (Vtyp.Arr_El.W in 7 .. 8); -- Could be 7 in vhdl87 - pragma Assert (Vtyp.Abounds.Ndim = 1); - pragma Assert (Vtyp.Abounds.D (1).Len = Res'Length); - - for I in 1 .. Vlen loop - Res (Res'First + Natural (I - 1)) := - Character'Val (Read_U8 (Val.Val.Mem + Size_Type (I - 1))); - end loop; - end Convert_String; - - -- Convert filename VAL to RES + LEN. - procedure Convert_File_Name (Val : Valtyp; - Res : out C_File_Name; - Len : out Natural; - Status : out Op_Status) - is - Name : constant Valtyp := Strip_Alias_Const (Val); - pragma Unreferenced (Val); - begin - Len := Natural (Name.Typ.Abounds.D (1).Len); - - if Len >= Res'Length - 1 then - Status := Op_Filename_Error; - return; - end if; - - Convert_String (Name, Res (1 .. Len)); - Res (Len + 1) := Grt.Types.NUL; - - Status := Op_Ok; - end Convert_File_Name; - - procedure Set_Design_Unit (Unit : Node) is - begin - Current_Unit := Unit; - Current_Pfx_Id := No_Name_Id; - end Set_Design_Unit; - - function Synth_Open (Name : Ghdl_C_String; Mode : Ghdl_C_String) - return Grt.Stdio.FILEs - is - use Grt.Stdio; - Res : FILEs; - begin - -- Try to open the file using the name given. - Res := fopen (To_Address (Name), To_Address (Mode)); - if Res /= NULL_Stream then - -- File found. - return Res; - end if; - - -- Return now if the search path is not used: - -- mode is not read, or - -- no search path given. - if Mode (1) /= 'r' then - return Res; - end if; - if Current_Unit = Null_Node then - return NULL_Stream; - end if; - - -- The search path is given by the current unit. Extract it from the - -- filename (and cache the result). - if Current_Pfx_Id = No_Name_Id then - declare - use Files_Map; - use Name_Table; - - Loc : Location_Type; - Sfe : Source_File_Entry; - Name_Len : Natural; - Name_Ptr : Thin_String_Ptr; - begin - Loc := Get_Location (Current_Unit); - Sfe := Location_To_File (Loc); - Current_Pfx_Id := Get_File_Name (Sfe); - Name_Len := Get_Name_Length (Current_Pfx_Id); - Name_Ptr := Get_Name_Ptr (Current_Pfx_Id); - Current_Pfx_Len := 0; - for I in reverse 1 .. Name_Len loop - if Name_Ptr (I) = '/' or else Name_Ptr (I) = '\' then - Current_Pfx_Len := I; - exit; - end if; - end loop; - end; - end if; - - -- No prefix. - if Current_Pfx_Len = 0 then - return NULL_Stream; - end if; - - -- Try with prefix + name. - declare - use Name_Table; - Name_Len : constant Natural := strlen (Name); - Pfx : constant Thin_String_Ptr := Get_Name_Ptr (Current_Pfx_Id); - Name2 : String (1 .. Name_Len + Current_Pfx_Len + 1); - begin - Name2 (1 .. Current_Pfx_Len) := Pfx (1 .. Current_Pfx_Len); - Name2 (Current_Pfx_Len + 1 .. Current_Pfx_Len + Name_Len) := - Name (1 .. Name_Len); - Name2 (Name2'Last) := NUL; - Res := fopen (Name2'Address, To_Address (Mode)); - end; - - return Res; - end Synth_Open; - - function Elaborate_File_Declaration - (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index - is - File_Type : constant Node := Get_Type (Decl); - External_Name : constant Node := Get_File_Logical_Name (Decl); - Open_Kind : constant Node := Get_File_Open_Kind (Decl); - File_Name : Valtyp; - C_Name : C_File_Name; - C_Name_Len : Natural; - Mode : Valtyp; - F : File_Index; - File_Mode : Ghdl_I32; - Status : Op_Status; - begin - -- Use our own handler to open a file. - -- We need to do this assignment only once, but it is simpler to do it - -- here. - Open_Handler := Synth_Open'Access; - - if Get_Text_File_Flag (File_Type) then - F := Ghdl_Text_File_Elaborate; - else - declare - File_Typ : Type_Acc; - Cstr : Ghdl_C_String; - begin - File_Typ := Get_Subtype_Object (Syn_Inst, File_Type); - if File_Typ.File_Signature = null then - Cstr := null; - else - Cstr := To_Ghdl_C_String (File_Typ.File_Signature.all'Address); - end if; - F := Ghdl_File_Elaborate (Cstr); - end; - end if; - - -- LRM93 4.3.1.4 - -- If file open information is not included in a given file declaration, - -- then the file declared by the declaration is not opened when the file - -- declaration is elaborated. - if External_Name = Null_Node then - return F; - end if; - - File_Name := Synth_Expression_With_Basetype (Syn_Inst, External_Name); - - if Open_Kind /= Null_Node then - Mode := Synth_Expression (Syn_Inst, Open_Kind); - File_Mode := Ghdl_I32 (Read_Discrete (Mode)); - else - case Get_Mode (Decl) is - when Iir_In_Mode => - File_Mode := Read_Mode; - when Iir_Out_Mode => - File_Mode := Write_Mode; - when others => - raise Internal_Error; - end case; - end if; - - Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); - if Status = Op_Ok then - if Get_Text_File_Flag (File_Type) then - Ghdl_Text_File_Open - (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); - else - Ghdl_File_Open - (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); - end if; - end if; - - if Status /= Op_Ok then - if Status = Op_Name_Error then - Error_Msg_Synth - (+Decl, "cannot open file: " & C_Name (1 .. C_Name_Len)); - Set_Error (Syn_Inst); - else - File_Error (Decl, Status); - end if; - end if; - - return F; - end Elaborate_File_Declaration; - - function Endfile (F : File_Index; Loc : Syn_Src) return Boolean - is - Status : Op_Status; - begin - Ghdl_File_Endfile (F, Status); - - if Status = Op_Ok then - return False; - elsif Status = Op_End_Of_File then - return True; - else - File_Error (Loc, Status); - end if; - end Endfile; - - -- Declaration - -- procedure FILE_OPEN (file F : FT; - -- External_Name : String; - -- Open_Kind : File_Open_Kind); - procedure Synth_File_Open - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) - is - Inters : constant Node := Get_Interface_Declaration_Chain (Imp); - F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; - Param2 : constant Node := Get_Chain (Inters); - File_Name : constant Valtyp := Get_Value (Syn_Inst, Param2); - Param3 : constant Node := Get_Chain (Param2); - Open_Kind : constant Valtyp := Get_Value (Syn_Inst, Param3); - C_Name : C_File_Name; - C_Name_Len : Natural; - File_Mode : Ghdl_I32; - Status : Op_Status; - begin - Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); - if Status = Op_Ok then - File_Mode := Ghdl_I32 (Read_Discrete (Open_Kind)); - if Get_Text_File_Flag (Get_Type (Inters)) then - Ghdl_Text_File_Open - (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); - else - Ghdl_File_Open - (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); - end if; - end if; - - if Status /= Op_Ok then - if Status = Op_Name_Error then - Error_Msg_Synth - (+Loc, "cannot open file: " & C_Name (1 .. C_Name_Len)); - raise File_Execution_Error; - else - File_Error (Loc, Status); - end if; - end if; - end Synth_File_Open; - - -- Declaration - -- procedure FILE_CLOSE (file F : FT); - procedure Synth_File_Close - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) - is - Inters : constant Node := Get_Interface_Declaration_Chain (Imp); - F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; - Status : Op_Status; - begin - if Get_Text_File_Flag (Get_Type (Inters)) then - Ghdl_Text_File_Close (F, Status); - else - Ghdl_File_Close (F, Status); - end if; - - if Status /= Op_Ok then - File_Error (Loc, Status); - end if; - end Synth_File_Close; - - -- Declaration: - -- procedure untruncated_text_read --!V87 - -- (file f : text; str : out string; len : out natural); --!V87 - procedure Synth_Untruncated_Text_Read (Syn_Inst : Synth_Instance_Acc; - Imp : Node; - Loc : Node) - is - Inters : constant Node := Get_Interface_Declaration_Chain (Imp); - File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; - Param2 : constant Node := Get_Chain (Inters); - Str : constant Valtyp := Get_Value (Syn_Inst, Param2); - Param3 : constant Node := Get_Chain (Param2); - Param_Len : constant Valtyp := Get_Value (Syn_Inst, Param3); - Buf : String (1 .. Natural (Str.Typ.Abounds.D (1).Len)); - Len : Std_Integer; - Status : Op_Status; - begin - Len := Std_Integer (Buf'Last); - Ghdl_Untruncated_Text_Read - (File, To_Ghdl_C_String (Buf'Address), Len, Status); - if Status /= Op_Ok then - File_Error (Loc, Status); - end if; - - for I in 1 .. Natural (Len) loop - Write_U8 (Str.Val.Mem + Size_Type (I - 1), Character'Pos (Buf (I))); - end loop; - - Write_Discrete (Param_Len, Int64 (Len)); - end Synth_Untruncated_Text_Read; - - procedure File_Read_Value (File : File_Index; Val : Memtyp; Loc : Node) - is - Status : Op_Status; - begin - case Val.Typ.Kind is - when Type_Discrete - | Type_Bit - | Type_Logic - | Type_Float => - Ghdl_Read_Scalar (File, Ghdl_Ptr (Val.Mem.all'Address), - Ghdl_Index_Type (Val.Typ.Sz), Status); - if Status /= Op_Ok then - File_Error (Loc, Status); - end if; - when Type_Vector - | Type_Array => - declare - El_Typ : constant Type_Acc := Get_Array_Element (Val.Typ); - Off : Size_Type; - begin - Off := 0; - for I in 1 .. Get_Array_Flat_Length (Val.Typ) loop - File_Read_Value (File, (El_Typ, Val.Mem + Off), Loc); - Off := Off + El_Typ.Sz; - end loop; - end; - when Type_Record => - for I in Val.Typ.Rec.E'Range loop - File_Read_Value - (File, - (Val.Typ.Rec.E (I).Typ, Val.Mem + Val.Typ.Rec.E (I).Moff), - Loc); - end loop; - when Type_Unbounded_Record - | Type_Unbounded_Array - | Type_Unbounded_Vector - | Type_Protected - | Type_Slice - | Type_File - | Type_Access => - raise Internal_Error; - end case; - end File_Read_Value; - - procedure Synth_File_Read - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) - is - Inters : constant Node := Get_Interface_Declaration_Chain (Imp); - File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; - Param2 : constant Node := Get_Chain (Inters); - Value : constant Valtyp := Get_Value (Syn_Inst, Param2); - begin - File_Read_Value (File, (Value.Typ, Value.Val.Mem), Loc); - end Synth_File_Read; - -end Synth.Vhdl_Files; diff --git a/src/synth/synth-vhdl_files.ads b/src/synth/synth-vhdl_files.ads deleted file mode 100644 index 1d373664e..000000000 --- a/src/synth/synth-vhdl_files.ads +++ /dev/null @@ -1,48 +0,0 @@ --- Create declarations for 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 Vhdl.Nodes; use Vhdl.Nodes; - -with Synth.Source; use Synth.Source; -with Synth.Values; use Synth.Values; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; - -package Synth.Vhdl_Files is - -- Raised in case of un-recoverable error. - File_Execution_Error : exception; - - -- Set the current design unit, so that its path can be used to search - -- files. - procedure Set_Design_Unit (Unit : Node); - - function Elaborate_File_Declaration - (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index; - - function Endfile (F : File_Index; Loc : Syn_Src) return Boolean; - - procedure Synth_File_Open - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); - procedure Synth_File_Close - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); - - procedure Synth_Untruncated_Text_Read - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); - - procedure Synth_File_Read - (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node); -end Synth.Vhdl_Files; diff --git a/src/synth/synth-vhdl_heap.adb b/src/synth/synth-vhdl_heap.adb deleted file mode 100644 index 6ab9af3e5..000000000 --- a/src/synth/synth-vhdl_heap.adb +++ /dev/null @@ -1,94 +0,0 @@ --- Heap for 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 Tables; - - -with Synth.Memtype; use Synth.Memtype; - -package body Synth.Vhdl_Heap is - - package Heap_Table is new Tables - (Table_Component_Type => Valtyp, - Table_Index_Type => Heap_Index, - Table_Low_Bound => 1, - Table_Initial => 16); - - function Alloc_Mem (Sz : Size_Type) return Memory_Ptr; - pragma Import (C, Alloc_Mem, "malloc"); - - function Allocate_Memory (T : Type_Acc) return Value_Acc - is - M : Memory_Ptr; - begin - M := Alloc_Mem (T.Sz); - return new Value_Type'(Kind => Value_Memory, Mem => M); - end Allocate_Memory; - - function Allocate_By_Type (T : Type_Acc) return Value_Acc - is - Res : Value_Acc; - begin - Res := Allocate_Memory (T); - Write_Value_Default (Res.Mem, T); - return Res; - end Allocate_By_Type; - - function Allocate_By_Type (T : Type_Acc) return Heap_Index is - begin - -- FIXME: allocate type. - Heap_Table.Append ((T, Allocate_By_Type (T))); - return Heap_Table.Last; - end Allocate_By_Type; - - function Allocate_By_Value (V : Valtyp) return Value_Acc - is - Res : Value_Acc; - begin - Res := Allocate_Memory (V.Typ); - Write_Value (Res.Mem, V); - return Res; - end Allocate_By_Value; - - function Allocate_By_Value (V : Valtyp) return Heap_Index is - begin - Heap_Table.Append ((V.Typ, Allocate_By_Value (V))); - return Heap_Table.Last; - end Allocate_By_Value; - - function Synth_Dereference (Idx : Heap_Index) return Valtyp is - begin - return Heap_Table.Table (Idx); - end Synth_Dereference; - - procedure Free (Obj : in out Valtyp) is - begin - -- TODO - Obj := No_Valtyp; - end Free; - - procedure Synth_Deallocate (Idx : Heap_Index) is - begin - if Heap_Table.Table (Idx) = No_Valtyp then - return; - end if; - Free (Heap_Table.Table (Idx)); - end Synth_Deallocate; - -end Synth.Vhdl_Heap; diff --git a/src/synth/synth-vhdl_heap.ads b/src/synth/synth-vhdl_heap.ads deleted file mode 100644 index 0e1928b26..000000000 --- a/src/synth/synth-vhdl_heap.ads +++ /dev/null @@ -1,30 +0,0 @@ --- Heap for 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 Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; - -package Synth.Vhdl_Heap is - -- Allocate a value. - function Allocate_By_Type (T : Type_Acc) return Heap_Index; - function Allocate_By_Value (V : Valtyp) return Heap_Index; - - function Synth_Dereference (Idx : Heap_Index) return Valtyp; - - procedure Synth_Deallocate (Idx : Heap_Index); -end Synth.Vhdl_Heap; diff --git a/src/synth/synth-vhdl_insts.adb b/src/synth/synth-vhdl_insts.adb index 1297c71b9..5394834ab 100644 --- a/src/synth/synth-vhdl_insts.adb +++ b/src/synth/synth-vhdl_insts.adb @@ -21,7 +21,6 @@ with GNAT.SHA1; with Types; use Types; with Types_Utils; use Types_Utils; with Name_Table; -with Libraries; with Hash; use Hash; with Dyn_Tables; with Interning; @@ -34,24 +33,27 @@ with Netlists.Builders; use Netlists.Builders; with Netlists.Concats; with Netlists.Folds; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Errors; with Vhdl.Ieee.Math_Real; -with Synth.Memtype; use Synth.Memtype; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Files; +with Elab.Debugger; + with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Source; use Synth.Source; -with Synth.Debugger; -with Synth.Vhdl_Files; with Synth.Errors; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; package body Synth.Vhdl_Insts is - Root_Instance : Synth_Instance_Acc; + Global_Base_Instance : Base_Instance_Acc; function Mode_To_Port_Kind (Mode : Iir_Mode) return Port_Kind is begin @@ -202,6 +204,7 @@ package body Synth.Vhdl_Insts is Hash_Const (C, Val.A_Obj, Typ); when Value_Net | Value_Wire + | Value_Signal | Value_File => raise Internal_Error; end case; @@ -335,35 +338,6 @@ package body Synth.Vhdl_Insts is return New_Sname_User (Get_Encoded_Name_Id (Decl, Enc), No_Sname); end Create_Inter_Name; - procedure Copy_Object_Subtype (Syn_Inst : Synth_Instance_Acc; - Inter_Type : Node; - Proto_Inst : Synth_Instance_Acc) - is - Inter_Typ : Type_Acc; - begin - case Get_Kind (Inter_Type) is - when Iir_Kind_Array_Subtype_Definition => - if Synth.Vhdl_Decls.Has_Element_Subtype_Indication (Inter_Type) - then - Copy_Object_Subtype - (Syn_Inst, Get_Element_Subtype (Inter_Type), Proto_Inst); - end if; - when others => - null; - end case; - Inter_Typ := Get_Subtype_Object (Proto_Inst, Inter_Type); - Create_Subtype_Object (Syn_Inst, Inter_Type, Inter_Typ); - end Copy_Object_Subtype; - - procedure Build_Object_Subtype (Syn_Inst : Synth_Instance_Acc; - Inter : Node; - Proto_Inst : Synth_Instance_Acc) is - begin - if Get_Declaration_Type (Inter) /= Null_Node then - Copy_Object_Subtype (Syn_Inst, Get_Type (Inter), Proto_Inst); - end if; - end Build_Object_Subtype; - -- Return the number of ports for a type. A record type create one -- port per immediate subelement. Sub-records are not expanded. function Count_Nbr_Ports (Typ : Type_Acc) return Port_Nbr is @@ -442,8 +416,6 @@ package body Synth.Vhdl_Insts is is Decl : constant Node := Params.Decl; Arch : constant Node := Params.Arch; - Imp : Node; - Syn_Inst : Synth_Instance_Acc; Inter : Node; Inter_Typ : Type_Acc; Nbr_Inputs : Port_Nbr; @@ -453,28 +425,10 @@ package body Synth.Vhdl_Insts is Val : Valtyp; Id : Module_Id; begin - if Get_Kind (Params.Decl) = Iir_Kind_Component_Declaration then - pragma Assert (Params.Arch = Null_Node); - pragma Assert (Params.Config = Null_Node); - Imp := Params.Decl; - else - pragma Assert - (Get_Kind (Params.Config) = Iir_Kind_Block_Configuration); - Imp := Params.Arch; - end if; - - -- Create the instance. - Syn_Inst := Make_Instance (Root_Instance, Imp, No_Sname); - -- Copy values for generics. Inter := Get_Generic_Chain (Decl); Nbr_Params := 0; while Inter /= Null_Node loop - -- Bounds or range of the type. - Build_Object_Subtype (Syn_Inst, Inter, Params.Syn_Inst); - - -- Object. - Create_Object (Syn_Inst, Inter, Get_Value (Params.Syn_Inst, Inter)); Nbr_Params := Nbr_Params + 1; Inter := Get_Chain (Inter); end loop; @@ -484,12 +438,6 @@ package body Synth.Vhdl_Insts is Nbr_Inputs := 0; Nbr_Outputs := 0; while Is_Valid (Inter) loop - -- Copy the type from PARAMS if needed. The subtype indication of - -- the port may reference objects that aren't anymore reachable - -- (particularly if it is a port of a component). So the subtype - -- cannot be regularly elaborated. - -- Also, for unconstrained subtypes, we need the constraint. - Build_Object_Subtype (Syn_Inst, Inter, Params.Syn_Inst); Inter_Typ := Get_Value (Params.Syn_Inst, Inter).Typ; case Mode_To_Port_Kind (Get_Mode (Inter)) is @@ -501,7 +449,7 @@ package body Synth.Vhdl_Insts is Val := Create_Value_Wire (No_Wire_Id, Inter_Typ); Nbr_Outputs := Nbr_Outputs + Count_Nbr_Ports (Inter_Typ); end case; - Create_Object (Syn_Inst, Inter, Val); + Replace_Signal (Params.Syn_Inst, Inter, Val); Inter := Get_Chain (Inter); end loop; @@ -552,7 +500,7 @@ package body Synth.Vhdl_Insts is Nbr_Outputs := 0; while Is_Valid (Inter) loop Pkind := Mode_To_Port_Kind (Get_Mode (Inter)); - Vt := Get_Value (Syn_Inst, Inter); + Vt := Get_Value (Params.Syn_Inst, Inter); case Pkind is when Port_In => @@ -572,10 +520,12 @@ package body Synth.Vhdl_Insts is Set_Ports_Desc (Cur_Module, Inports, Outports); end; + Set_Extra (Params.Syn_Inst, Global_Base_Instance, No_Sname); + return Inst_Object'(Decl => Decl, Arch => Arch, Config => Params.Config, - Syn_Inst => Syn_Inst, + Syn_Inst => Params.Syn_Inst, M => Cur_Module, Encoding => Params.Encoding); end Build; @@ -980,92 +930,18 @@ package body Synth.Vhdl_Insts is end if; end Synth_Instantiate_Module; - function Synth_Port_Association_Type (Sub_Inst : Synth_Instance_Acc; - Syn_Inst : Synth_Instance_Acc; - Inter : Node; - Assoc : Node) return Type_Acc is - begin - if not Is_Fully_Constrained_Type (Get_Type (Inter)) then - -- TODO - -- Find the association for this interface - -- * if individual assoc: get type - -- * if whole assoc: get type from object. - if Assoc = Null_Node then - raise Internal_Error; - end if; - case Get_Kind (Assoc) is - when Iir_Kinds_Association_Element_By_Actual => - return Synth_Type_Of_Object (Syn_Inst, Get_Actual (Assoc)); - when others => - raise Internal_Error; - end case; - else - Synth_Declaration_Type (Sub_Inst, Inter); - return Get_Subtype_Object (Sub_Inst, Get_Type (Inter)); - end if; - end Synth_Port_Association_Type; - - procedure Synth_Ports_Association_Type (Sub_Inst : Synth_Instance_Acc; - Syn_Inst : Synth_Instance_Acc; - Inter_Chain : Node; - Assoc_Chain : Node) - is - Inter : Node; - Assoc : Node; - Assoc_Inter : Node; - Val : Valtyp; - Inter_Typ : Type_Acc; - begin - Assoc := Assoc_Chain; - Assoc_Inter := Inter_Chain; - while Is_Valid (Assoc) loop - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - if Get_Whole_Association_Flag (Assoc) then - Inter_Typ := Synth_Port_Association_Type - (Sub_Inst, Syn_Inst, Inter, Assoc); - case Mode_To_Port_Kind (Get_Mode (Inter)) is - when Port_In => - Val := Create_Value_Net (No_Net, Inter_Typ); - when Port_Out - | Port_Inout => - Val := Create_Value_Wire (No_Wire_Id, Inter_Typ); - end case; - Create_Object (Sub_Inst, Inter, Val); - end if; - Next_Association_Interface (Assoc, Assoc_Inter); - end loop; - end Synth_Ports_Association_Type; - procedure Synth_Direct_Instantiation_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node; + Sub_Inst : Synth_Instance_Acc; Ent : Node; Arch : Node; Config : Node) is - Sub_Inst : Synth_Instance_Acc; Inst_Obj : Inst_Object; Inst : Instance; Enc : Name_Encoding; begin - -- Elaborate generic + map aspect - Sub_Inst := Make_Instance - (Syn_Inst, Ent, New_Sname_User (Get_Identifier (Ent), No_Sname)); - - Synth_Generics_Association (Sub_Inst, Syn_Inst, - Get_Generic_Chain (Ent), - Get_Generic_Map_Aspect_Chain (Stmt)); - - -- Elaborate port types. - Synth_Ports_Association_Type (Sub_Inst, Syn_Inst, - Get_Port_Chain (Ent), - Get_Port_Map_Aspect_Chain (Stmt)); - - if Is_Error (Sub_Inst) then - -- TODO: Free it? - return; - end if; - if Arch /= Null_Node then -- For whiteboxes: append parameters or/and hash. Enc := Name_Hash; @@ -1085,8 +961,8 @@ package body Synth.Vhdl_Insts is Syn_Inst => Sub_Inst, Encoding => Enc)); - -- TODO: free sub_inst. + -- Do the instantiation. Inst := New_Instance (Get_Instance_Module (Syn_Inst), Inst_Obj.M, @@ -1104,43 +980,26 @@ package body Synth.Vhdl_Insts is procedure Synth_Design_Instantiation_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is - Aspect : constant Iir := Get_Instantiated_Unit (Stmt); - Arch : Node; - Ent : Node; - Config : Node; + Sub_Inst : constant Synth_Instance_Acc := + Get_Sub_Instance (Syn_Inst, Stmt); + Arch : constant Node := Get_Source_Scope (Sub_Inst); + Ent : constant Node := Get_Entity (Arch); + Config : constant Node := Get_Instance_Config (Sub_Inst); begin - -- Load configured entity + architecture - case Iir_Kinds_Entity_Aspect (Get_Kind (Aspect)) is - when Iir_Kind_Entity_Aspect_Entity => - Arch := Get_Architecture (Aspect); - if Arch = Null_Node then - Arch := Libraries.Get_Latest_Architecture (Get_Entity (Aspect)); - else - Arch := Strip_Denoting_Name (Arch); - end if; - Config := Get_Library_Unit - (Get_Default_Configuration_Declaration (Arch)); - when Iir_Kind_Entity_Aspect_Configuration => - Config := Get_Configuration (Aspect); - Arch := Get_Block_Specification (Get_Block_Configuration (Config)); - when Iir_Kind_Entity_Aspect_Open => - return; - end case; - Config := Get_Block_Configuration (Config); - Ent := Get_Entity (Arch); - Synth_Direct_Instantiation_Statement - (Syn_Inst, Stmt, Ent, Arch, Config); + (Syn_Inst, Stmt, Sub_Inst, Ent, Arch, Config); end Synth_Design_Instantiation_Statement; procedure Synth_Blackbox_Instantiation_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is + Sub_Inst : constant Synth_Instance_Acc := + Get_Sub_Instance (Syn_Inst, Stmt); Comp : constant Node := Get_Named_Entity (Get_Instantiated_Unit (Stmt)); begin Synth_Direct_Instantiation_Statement - (Syn_Inst, Stmt, Comp, Null_Node, Null_Node); + (Syn_Inst, Stmt, Sub_Inst, Comp, Null_Node, Null_Node); end Synth_Blackbox_Instantiation_Statement; procedure Create_Component_Wire (Ctxt : Context_Acc; @@ -1155,12 +1014,13 @@ package body Synth.Vhdl_Insts is case Val.Val.Kind is when Value_Wire => -- Create a gate for the output, so that it could be read. - Val.Val.W := Alloc_Wire (Wire_Output, (Inter, Bit_Type)); + Set_Value_Wire + (Val.Val, Alloc_Wire (Wire_Output, (Inter, Bit_Type))); W := Get_Type_Width (Val.Typ); Value := Build_Signal (Ctxt, New_Internal_Name (Ctxt, Pfx_Name), W); Set_Location (Value, Loc); - Set_Wire_Gate (Val.Val.W, Value); + Set_Wire_Gate (Get_Value_Wire (Val.Val), Value); when others => raise Internal_Error; end case; @@ -1170,12 +1030,13 @@ package body Synth.Vhdl_Insts is (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); + Comp_Inst : constant Synth_Instance_Acc := + Get_Sub_Instance (Syn_Inst, Stmt); + Config : constant Node := Get_Instance_Config (Comp_Inst); Component : constant Node := Get_Named_Entity (Get_Instantiated_Unit (Stmt)); - Config : constant Node := Get_Component_Configuration (Stmt); Bind : constant Node := Get_Binding_Indication (Config); Aspect : constant Node := Get_Entity_Aspect (Bind); - Comp_Inst : Synth_Instance_Acc; Ent : Node; Arch : Node; @@ -1185,7 +1046,6 @@ package body Synth.Vhdl_Insts is Inst : Instance; Inst_Name : Sname; begin - pragma Assert (Get_Component_Configuration (Stmt) /= Null_Node); pragma Assert (Get_Kind (Aspect) = Iir_Kind_Entity_Aspect_Entity); Push_Phi; @@ -1193,15 +1053,7 @@ package body Synth.Vhdl_Insts is Inst_Name := New_Sname_User (Get_Identifier (Stmt), Get_Sname (Syn_Inst)); - -- Create the sub-instance for the component - -- Elaborate generic + map aspect - Comp_Inst := Make_Instance - (Syn_Inst, Component, - New_Sname_User (Get_Identifier (Component), No_Sname)); - - Synth_Generics_Association (Comp_Inst, Syn_Inst, - Get_Generic_Chain (Component), - Get_Generic_Map_Aspect_Chain (Stmt)); + Set_Extra (Comp_Inst, Syn_Inst, Inst_Name); -- Create objects for the inputs and the outputs of the component, -- assign inputs (that's nets) and create wires for outputs. @@ -1218,9 +1070,8 @@ package body Synth.Vhdl_Insts is while Is_Valid (Assoc) loop if Get_Whole_Association_Flag (Assoc) then Inter := Get_Association_Interface (Assoc, Assoc_Inter); - - Inter_Typ := Synth_Port_Association_Type - (Comp_Inst, Syn_Inst, Inter, Assoc); + Val := Get_Value (Comp_Inst, Inter); + Inter_Typ := Val.Typ; case Mode_To_Port_Kind (Get_Mode (Inter)) is when Port_In => @@ -1234,46 +1085,25 @@ package body Synth.Vhdl_Insts is (Get_Build (Syn_Inst), Assoc_Inter, Val, Inst_Name, Assoc); end case; - Create_Object (Comp_Inst, Assoc_Inter, Val); + Replace_Signal (Comp_Inst, Assoc_Inter, Val); end if; Next_Association_Interface (Assoc, Assoc_Inter); end loop; end; - -- Extract entity/architecture instantiated by the component. - case Get_Kind (Aspect) is - when Iir_Kind_Entity_Aspect_Entity => - Ent := Get_Entity (Aspect); - Arch := Get_Architecture (Aspect); - when others => - Vhdl.Errors.Error_Kind - ("Synth_Component_Instantiation_Statement(2)", Aspect); - end case; + Sub_Inst := Get_Component_Instance (Comp_Inst); + Arch := Get_Source_Scope (Sub_Inst); + Ent := Get_Entity (Arch); + Sub_Config := Get_Instance_Config (Sub_Inst); if Get_Kind (Ent) = Iir_Kind_Foreign_Module then -- TODO. raise Internal_Error; end if; - if Arch = Null_Node then - Arch := Libraries.Get_Latest_Architecture (Ent); - else - Arch := Get_Named_Entity (Arch); - end if; - Sub_Config := Get_Library_Unit - (Get_Default_Configuration_Declaration (Arch)); - Sub_Config := Get_Block_Configuration (Sub_Config); - -- Elaborate generic + map aspect for the entity instance. - Sub_Inst := Make_Instance - (Comp_Inst, Ent, New_Sname_User (Get_Identifier (Ent), No_Sname)); - Synth_Generics_Association (Sub_Inst, Comp_Inst, - Get_Generic_Chain (Ent), - Get_Generic_Map_Aspect_Chain (Bind)); - - Synth_Ports_Association_Type (Sub_Inst, Comp_Inst, - Get_Port_Chain (Ent), - Get_Port_Map_Aspect_Chain (Bind)); + Set_Extra (Sub_Inst, + Comp_Inst, New_Sname_User (Get_Identifier (Ent), No_Sname)); -- Search if corresponding module has already been used. -- If not create a new module @@ -1387,17 +1217,13 @@ package body Synth.Vhdl_Insts is procedure Synth_Top_Entity (Base : Base_Instance_Acc; Design_Unit : Node; Encoding : Name_Encoding; - Inst : out Synth_Instance_Acc) + Syn_Inst : Synth_Instance_Acc) is Lib_Unit : constant Node := Get_Library_Unit (Design_Unit); Arch : Node; Entity : Node; Config : Node; - Syn_Inst : Synth_Instance_Acc; - Inter : Node; - Inter_Typ : Type_Acc; Inst_Obj : Inst_Object; - Val : Valtyp; begin -- Extract architecture from design. case Get_Kind (Lib_Unit) is @@ -1414,60 +1240,22 @@ package body Synth.Vhdl_Insts is end case; Entity := Get_Entity (Arch); - Root_Instance := Make_Base_Instance (Base); + Make_Base_Instance (Base); + + Global_Base_Instance := Base; Insts_Interning.Init; if Flags.Flag_Debug_Init then - Synth.Debugger.Debug_Init (Arch); + Elab.Debugger.Debug_Init (Arch); end if; -- Dependencies first. Synth_Dependencies (Root_Instance, Get_Design_Unit (Entity)); Synth_Dependencies (Root_Instance, Get_Design_Unit (Arch)); - Syn_Inst := Make_Instance - (Root_Instance, Arch, - New_Sname_User (Get_Identifier (Entity), No_Sname)); - - -- Compute generics. - Inter := Get_Generic_Chain (Entity); - while Is_Valid (Inter) loop - Synth_Declaration_Type (Syn_Inst, Inter); - declare - Val : Valtyp; - Inter_Typ : Type_Acc; - begin - Inter_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Inter)); - Val := Synth_Expression_With_Type - (Syn_Inst, Get_Default_Value (Inter), Inter_Typ); - pragma Assert (Is_Static (Val.Val)); - Create_Object (Syn_Inst, Inter, Val); - end; - Inter := Get_Chain (Inter); - end loop; - - -- Elaborate port types. - -- FIXME: what about unconstrained ports ? Get the type from the - -- association. - Inter := Get_Port_Chain (Entity); - while Is_Valid (Inter) loop - if not Is_Fully_Constrained_Type (Get_Type (Inter)) then - -- TODO - raise Internal_Error; - end if; - Synth_Declaration_Type (Syn_Inst, Inter); - Inter_Typ := Get_Subtype_Object (Syn_Inst, Get_Type (Inter)); - case Mode_To_Port_Kind (Get_Mode (Inter)) is - when Port_In => - Val := Create_Value_Net (No_Net, Inter_Typ); - when Port_Out - | Port_Inout => - Val := Create_Value_Wire (No_Wire_Id, Inter_Typ); - end case; - Create_Object (Syn_Inst, Inter, Val); - Inter := Get_Chain (Inter); - end loop; + Set_Extra + (Syn_Inst, Base, New_Sname_User (Get_Identifier (Entity), No_Sname)); -- Search if corresponding module has already been used. -- If not create a new module @@ -1480,16 +1268,20 @@ package body Synth.Vhdl_Insts is Config => Get_Block_Configuration (Config), Syn_Inst => Syn_Inst, Encoding => Encoding)); - Inst := Inst_Obj.Syn_Inst; + pragma Unreferenced (Inst_Obj); end Synth_Top_Entity; procedure Create_Input_Wire (Syn_Inst : Synth_Instance_Acc; Self_Inst : Instance; Idx : in out Port_Idx; - Val : Valtyp) is + Val : Valtyp) + is + N : Net; begin pragma Assert (Val.Val.Kind = Value_Net); - Inst_Output_Connect (Syn_Inst, Self_Inst, Idx, Val.Typ, Val.Val.N); + N := Get_Value_Net (Val.Val); + Inst_Output_Connect (Syn_Inst, Self_Inst, Idx, Val.Typ, N); + Set_Value_Net (Val.Val, N); end Create_Input_Wire; procedure Create_Output_Wire (Syn_Inst : Synth_Instance_Acc; @@ -1511,7 +1303,7 @@ package body Synth.Vhdl_Insts is pragma Assert (Val.Val.Kind = Value_Wire); -- Create a gate for the output, so that it could be read. - Val.Val.W := Alloc_Wire (Wire_Output, (Inter, Val.Typ)); + Set_Value_Wire (Val.Val, Alloc_Wire (Wire_Output, (Inter, Val.Typ))); -- pragma Assert (Desc.W = Get_Type_Width (Val.Typ)); if Default /= Null_Node then @@ -1548,76 +1340,21 @@ package body Synth.Vhdl_Insts is Vout := Value; end if; Set_Location (Value, Inter); - Set_Wire_Gate (Val.Val.W, Value); + Set_Wire_Gate (Get_Value_Wire (Val.Val), Value); Inst_Input_Connect (Syn_Inst, Self_Inst, Idx, Val.Typ, Vout); end Create_Output_Wire; - procedure Apply_Block_Configuration (Cfg : Node; Blk : Node) - is - Item : Node; - begin - -- Be sure CFG applies to BLK. - pragma Assert (Get_Block_From_Block_Specification - (Get_Block_Specification (Cfg)) = Blk); - - -- Clear_Instantiation_Configuration (Blk); - - Item := Get_Configuration_Item_Chain (Cfg); - while Item /= Null_Node loop - case Get_Kind (Item) is - when Iir_Kind_Component_Configuration => - declare - List : constant Iir_Flist := - Get_Instantiation_List (Item); - El : Node; - Inst : Node; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Inst := Get_Named_Entity (El); - pragma Assert - (Get_Kind (Inst) - = Iir_Kind_Component_Instantiation_Statement); - pragma Assert - (Get_Component_Configuration (Inst) = Null_Node); - Set_Component_Configuration (Inst, Item); - end loop; - end; - when Iir_Kind_Block_Configuration => - declare - Sub_Blk : constant Node := Get_Block_From_Block_Specification - (Get_Block_Specification (Item)); - begin - case Get_Kind (Sub_Blk) is - when Iir_Kind_Generate_Statement_Body => - -- Linked chain. - Set_Prev_Block_Configuration - (Item, Get_Generate_Block_Configuration (Sub_Blk)); - Set_Generate_Block_Configuration (Sub_Blk, Item); - when Iir_Kind_Block_Statement => - Set_Block_Block_Configuration (Sub_Blk, Item); - when others => - Vhdl.Errors.Error_Kind - ("apply_block_configuration(blk)", Sub_Blk); - end case; - end; - when others => - Vhdl.Errors.Error_Kind ("apply_block_configuration", Item); - end case; - Item := Get_Chain (Item); - end loop; - end Apply_Block_Configuration; - - procedure Synth_Verification_Units - (Syn_Inst : Synth_Instance_Acc; Parent : Node) + procedure Synth_Verification_Units (Syn_Inst : Synth_Instance_Acc) is + Extra : Synth_Instance_Acc; Unit : Node; begin - Unit := Get_Bound_Vunit_Chain (Parent); - while Unit /= Null_Node loop - Synth_Verification_Unit (Syn_Inst, Unit); - Unit := Get_Bound_Vunit_Chain (Unit); + Extra := Get_First_Extra_Instance (Syn_Inst); + while Extra /= null loop + Unit := Get_Source_Scope (Extra); + Synth_Verification_Unit (Extra, Unit, Syn_Inst); + Extra := Get_Next_Extra_Instance (Syn_Inst); end loop; end Synth_Verification_Units; @@ -1643,7 +1380,7 @@ package body Synth.Vhdl_Insts is -- Save the current architecture, so that files can be open using a -- path relative to the architecture filename. - Synth.Vhdl_Files.Set_Design_Unit (Arch); + Elab.Vhdl_Files.Set_Design_Unit (Arch); Synth_Dependencies (Root_Instance, Get_Design_Unit (Arch)); @@ -1671,9 +1408,9 @@ package body Synth.Vhdl_Insts is -- Apply configuration. -- FIXME: what about inner block configuration ? pragma Assert (Get_Kind (Inst.Config) = Iir_Kind_Block_Configuration); - Apply_Block_Configuration (Inst.Config, Arch); - Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Entity)); + -- Entity + Synth_Concurrent_Declarations (Syn_Inst, Get_Declaration_Chain (Entity)); if not Is_Error (Syn_Inst) then Synth_Concurrent_Statements (Syn_Inst, Get_Concurrent_Statement_Chain (Entity)); @@ -1683,8 +1420,10 @@ package body Synth.Vhdl_Insts is Synth_Attribute_Values (Syn_Inst, Entity); end if; + -- Architecture if not Is_Error (Syn_Inst) then - Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Arch)); + Synth_Concurrent_Declarations + (Syn_Inst, Get_Declaration_Chain (Arch)); end if; if not Is_Error (Syn_Inst) then Synth_Concurrent_Statements @@ -1695,13 +1434,12 @@ package body Synth.Vhdl_Insts is Synth_Attribute_Values (Syn_Inst, Arch); end if; + -- Vunits if not Is_Error (Syn_Inst) then - Synth_Verification_Units (Syn_Inst, Entity); - end if; - if not Is_Error (Syn_Inst) then - Synth_Verification_Units (Syn_Inst, Arch); + Synth_Verification_Units (Syn_Inst); end if; + -- Finalize Finalize_Declarations (Syn_Inst, Get_Declaration_Chain (Arch)); Finalize_Declarations (Syn_Inst, Get_Port_Chain (Entity)); diff --git a/src/synth/synth-vhdl_insts.ads b/src/synth/synth-vhdl_insts.ads index c280475a6..ae7fd715d 100644 --- a/src/synth/synth-vhdl_insts.ads +++ b/src/synth/synth-vhdl_insts.ads @@ -16,10 +16,11 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . +with Elab.Vhdl_Context; use Elab.Vhdl_Context; + with Vhdl.Nodes; use Vhdl.Nodes; with Synth.Context; use Synth.Context; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Flags; use Synth.Flags; package Synth.Vhdl_Insts is @@ -27,16 +28,11 @@ package Synth.Vhdl_Insts is procedure Synth_Top_Entity (Base : Base_Instance_Acc; Design_Unit : Node; Encoding : Name_Encoding; - Inst : out Synth_Instance_Acc); + Syn_Inst : Synth_Instance_Acc); -- Synthesize the top entity and all the sub-modules. procedure Synth_All_Instances; - -- Apply block configuration CFG to BLK. - -- Must be done before synthesis of BLK. - -- The synthesis of BLK will clear all configuration of it. - procedure Apply_Block_Configuration (Cfg : Node; Blk : Node); - procedure Synth_Design_Instantiation_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node); procedure Synth_Blackbox_Instantiation_Statement diff --git a/src/synth/synth-vhdl_oper.adb b/src/synth/synth-vhdl_oper.adb index d7d73bcec..c576f2fee 100644 --- a/src/synth/synth-vhdl_oper.adb +++ b/src/synth/synth-vhdl_oper.adb @@ -32,12 +32,15 @@ with Netlists.Builders; use Netlists.Builders; with Netlists.Folds; use Netlists.Folds; with Netlists.Utils; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; + with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Source; with Synth.Static_Oper; use Synth.Static_Oper; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; package body Synth.Vhdl_Oper is procedure Set_Location (N : Net; Loc : Node) diff --git a/src/synth/synth-vhdl_oper.ads b/src/synth/synth-vhdl_oper.ads index 7efa711d9..3ae73df3d 100644 --- a/src/synth/synth-vhdl_oper.ads +++ b/src/synth/synth-vhdl_oper.ads @@ -18,9 +18,9 @@ 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; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; package Synth.Vhdl_Oper is function Synth_Predefined_Function_Call diff --git a/src/synth/synth-vhdl_static_proc.adb b/src/synth/synth-vhdl_static_proc.adb index 462896451..5dc31318b 100644 --- a/src/synth/synth-vhdl_static_proc.adb +++ b/src/synth/synth-vhdl_static_proc.adb @@ -18,10 +18,11 @@ with Vhdl.Errors; use Vhdl.Errors; -with Synth.Values; use Synth.Values; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; +with Elab.Vhdl_Heap; +with Elab.Vhdl_Files; use Elab.Vhdl_Files; + with Synth.Errors; use Synth.Errors; -with Synth.Vhdl_Files; use Synth.Vhdl_Files; -with Synth.Vhdl_Heap; package body Synth.Vhdl_Static_Proc is @@ -33,7 +34,7 @@ package body Synth.Vhdl_Static_Proc is begin Val := Read_Access (Param); if Val /= Null_Heap_Index then - Synth.Vhdl_Heap.Synth_Deallocate (Val); + Elab.Vhdl_Heap.Synth_Deallocate (Val); Write_Access (Param.Val.Mem, Null_Heap_Index); end if; end Synth_Deallocate; diff --git a/src/synth/synth-vhdl_static_proc.ads b/src/synth/synth-vhdl_static_proc.ads index 4fceb6c9d..c7bedbcce 100644 --- a/src/synth/synth-vhdl_static_proc.ads +++ b/src/synth/synth-vhdl_static_proc.ads @@ -16,7 +16,8 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -with Synth.Vhdl_Context; use Synth.Vhdl_Context; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; + with Vhdl.Nodes; use Vhdl.Nodes; package Synth.Vhdl_Static_Proc is diff --git a/src/synth/synth-vhdl_stmts.adb b/src/synth/synth-vhdl_stmts.adb index 81394abdb..989942244 100644 --- a/src/synth/synth-vhdl_stmts.adb +++ b/src/synth/synth-vhdl_stmts.adb @@ -41,16 +41,20 @@ with PSL.Nodes; with PSL.Subsets; with PSL.NFAs; -with Synth.Memtype; use Synth.Memtype; +with Elab.Memtype; use Elab.Memtype; +with Elab.Vhdl_Heap; +with Elab.Vhdl_Types; use Elab.Vhdl_Types; +with Elab.Vhdl_Expr; +with Elab.Debugger; + with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Vhdl_Insts; use Synth.Vhdl_Insts; with Synth.Source; with Synth.Vhdl_Static_Proc; -with Synth.Vhdl_Heap; with Synth.Flags; -with Synth.Debugger; +with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Netlists.Builders; use Netlists.Builders; with Netlists.Folds; use Netlists.Folds; @@ -244,7 +248,8 @@ package body Synth.Vhdl_Stmts is if Dest_Off /= (0, 0) and then Dest_Dyn.Voff /= No_Net then raise Internal_Error; end if; - Dest_Base := Vhdl_Heap.Synth_Dereference (Read_Access (Dest_Base)); + Dest_Base := Elab.Vhdl_Heap.Synth_Dereference + (Read_Access (Dest_Base)); Dest_Typ := Dest_Base.Typ; when others => @@ -320,7 +325,7 @@ package body Synth.Vhdl_Stmts is while Choice /= Null_Node loop pragma Assert (Get_Kind (Choice) = Iir_Kind_Choice_By_None); El := Get_Associated_Expr (Choice); - El_Typ := Synth_Type_Of_Object (Syn_Inst, El); + El_Typ := Elab.Vhdl_Expr.Exec_Type_Of_Object (Syn_Inst, El); Bnd := Get_Array_Bound (El_Typ, 1); Len := Len + Bnd.Len; Choice := Get_Chain (Choice); @@ -487,6 +492,7 @@ package body Synth.Vhdl_Stmts is is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); V : Valtyp; + W : Wire_Id; begin V := Synth_Subtype_Conversion (Ctxt, Val, Target.Targ_Type, False, Loc); pragma Unreferenced (Val); @@ -507,19 +513,19 @@ package body Synth.Vhdl_Stmts is end if; if Target.Obj.Val.Kind = Value_Wire then + W := Get_Value_Wire (Target.Obj.Val); if Is_Static (V.Val) and then V.Typ.Sz = Target.Obj.Typ.Sz then pragma Assert (Target.Off = (0, 0)); - Phi_Assign_Static - (Target.Obj.Val.W, Unshare (Get_Memtyp (V))); + Phi_Assign_Static (W, Unshare (Get_Memtyp (V))); else if V.Typ.W = 0 then -- Forget about null wires. return; end if; - Phi_Assign_Net (Ctxt, Target.Obj.Val.W, - Get_Net (Ctxt, V), Target.Off.Net_Off); + Phi_Assign_Net + (Ctxt, W, Get_Net (Ctxt, V), Target.Off.Net_Off); end if; else if not Is_Static (V.Val) then @@ -535,16 +541,16 @@ package body Synth.Vhdl_Stmts is when Target_Memory => declare Ctxt : constant Context_Acc := Get_Build (Syn_Inst); + W : constant Wire_Id := Get_Value_Wire (Target.Mem_Obj.Val); N : Net; begin N := Get_Current_Assign_Value - (Ctxt, Target.Mem_Obj.Val.W, + (Ctxt, W, Target.Mem_Dyn.Pfx_Off.Net_Off, Target.Mem_Dyn.Pfx_Typ.W); N := Build_Dyn_Insert (Ctxt, N, Get_Net (Ctxt, V), Target.Mem_Dyn.Voff, Target.Mem_Doff); Set_Location (N, Loc); - Phi_Assign_Net (Ctxt, Target.Mem_Obj.Val.W, N, - Target.Mem_Dyn.Pfx_Off.Net_Off); + Phi_Assign_Net (Ctxt, W, N, Target.Mem_Dyn.Pfx_Off.Net_Off); end; end case; end Synth_Assignment; @@ -1910,6 +1916,7 @@ package body Synth.Vhdl_Stmts is Assoc_Inter : Node; Val : Valtyp; Nbr_Inout : Natural; + W : Wire_Id; begin Nbr_Inout := 0; pragma Assert (Init.Kind = Association_Function); @@ -1928,8 +1935,9 @@ package body Synth.Vhdl_Stmts is -- Free wire used for out/inout interface variables. if Val.Val.Kind = Value_Wire then - Phi_Discard_Wires (Val.Val.W, No_Wire_Id); - Free_Wire (Val.Val.W); + W := Get_Value_Wire (Val.Val); + Phi_Discard_Wires (W, No_Wire_Id); + Free_Wire (W); end if; end if; @@ -2136,8 +2144,10 @@ package body Synth.Vhdl_Stmts is Areapools.Mark (Area_Mark, Instance_Pool.all); Up_Inst := Get_Instance_By_Scope (Syn_Inst, Get_Parent_Scope (Imp)); - Sub_Inst := Make_Instance (Up_Inst, Bod, New_Internal_Name (Ctxt)); - Set_Instance_Base (Sub_Inst, Syn_Inst); + Sub_Inst := Make_Elab_Instance (Up_Inst, Bod, Config => Null_Node); + if Ctxt /= null then + Set_Extra (Sub_Inst, Syn_Inst, New_Internal_Name (Ctxt)); + end if; Synth_Subprogram_Association (Sub_Inst, Syn_Inst, Init, Infos); @@ -2145,7 +2155,7 @@ package body Synth.Vhdl_Stmts is Res := No_Valtyp; else if not Is_Func then - if Get_Purity_State (Imp) /= Pure then + if Ctxt /= null and then Get_Purity_State (Imp) /= Pure then Set_Instance_Const (Sub_Inst, False); end if; end if; @@ -2164,8 +2174,8 @@ package body Synth.Vhdl_Stmts is Set_Error (Syn_Inst); end if; - if Debugger.Flag_Need_Debug then - Debugger.Debug_Leave (Sub_Inst); + if Elab.Debugger.Flag_Need_Debug then + Elab.Debugger.Debug_Leave (Sub_Inst); end if; Free_Instance (Sub_Inst); @@ -2214,7 +2224,11 @@ package body Synth.Vhdl_Stmts is Sub_Inst : Synth_Instance_Acc; begin Areapools.Mark (Area_Mark, Instance_Pool.all); - Sub_Inst := Make_Instance (Syn_Inst, Imp, New_Internal_Name (Ctxt)); + Sub_Inst := Make_Elab_Instance (Syn_Inst, Imp, Null_Node); + + if Ctxt /= null then + Set_Extra (Sub_Inst, Syn_Inst, New_Internal_Name (Ctxt)); + end if; Synth_Subprogram_Association (Sub_Inst, Syn_Inst, Init, Infos); @@ -2247,20 +2261,6 @@ package body Synth.Vhdl_Stmts is end case; end Synth_Procedure_Call; - procedure Update_Index (Rng : Discrete_Range_Type; V : in out Valtyp) - is - T : Int64; - begin - T := Read_Discrete (V); - case Rng.Dir is - when Dir_To => - T := T + 1; - when Dir_Downto => - T := T - 1; - end case; - Write_Discrete (V, T); - end Update_Index; - -- Return True iff WID is a static wire and its value is V. function Is_Static_Bit (Wid : Wire_Id; V : Ghdl_U8) return Boolean is @@ -2876,6 +2876,7 @@ package body Synth.Vhdl_Stmts is if Sev_V >= Flags.Severity_Level then Error_Msg_Synth (+Stmt, "error due to assertion failure"); + Elab.Debugger.Debug_Error (Syn_Inst, Stmt); end if; end Synth_Static_Report; @@ -2962,8 +2963,8 @@ package body Synth.Vhdl_Stmts is & Natural'Image (Line)); end; end if; - if Synth.Debugger.Flag_Need_Debug then - Synth.Debugger.Debug_Break (C.Inst, Stmt); + if Elab.Debugger.Flag_Need_Debug then + Elab.Debugger.Debug_Break (C.Inst, Stmt); end if; case Get_Kind (Stmt) is @@ -3205,34 +3206,25 @@ package body Synth.Vhdl_Stmts is is use Areapools; Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; - Blk_Inst : Synth_Instance_Acc; + Blk_Inst : constant Synth_Instance_Acc := + Get_Sub_Instance (Syn_Inst, Blk); + Decls_Chain : constant Node := Get_Declaration_Chain (Blk); Blk_Sname : Sname; M : Areapools.Mark_Type; begin - -- No support for guard or header. - if Get_Block_Header (Blk) /= Null_Node - or else Get_Guard_Decl (Blk) /= Null_Node - then - raise Internal_Error; - end if; - - Apply_Block_Configuration - (Get_Block_Block_Configuration (Blk), Blk); - Blk_Sname := New_Sname_User (Get_Identifier (Blk), Get_Sname (Syn_Inst)); - Blk_Inst := Make_Instance (Syn_Inst, Blk, Blk_Sname); + Set_Extra (Blk_Inst, Syn_Inst, Blk_Sname); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; - Synth_Declarations (Blk_Inst, Get_Declaration_Chain (Blk)); + Synth_Concurrent_Declarations (Blk_Inst, Decls_Chain); Synth_Concurrent_Statements (Blk_Inst, Get_Concurrent_Statement_Chain (Blk)); Synth_Attribute_Values (Blk_Inst, Blk); - Finalize_Declarations (Blk_Inst, Get_Declaration_Chain (Blk)); + Finalize_Declarations (Blk_Inst, Decls_Chain); - Free_Instance (Blk_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Block_Statement; @@ -3514,37 +3506,25 @@ package body Synth.Vhdl_Stmts is end Synth_Psl_Assert_Directive; procedure Synth_Generate_Statement_Body - (Syn_Inst : Synth_Instance_Acc; - Bod : Node; - Name : Sname; - Iterator : Node := Null_Node; - Iterator_Val : Valtyp := No_Valtyp) + (Syn_Inst : Synth_Instance_Acc; Bod : Node) is use Areapools; Decls_Chain : constant Node := Get_Declaration_Chain (Bod); Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; - Bod_Inst : Synth_Instance_Acc; M : Areapools.Mark_Type; begin - Bod_Inst := Make_Instance (Syn_Inst, Bod, Name); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; - if Iterator /= Null_Node then - -- Add the iterator (for for-generate). - Create_Object (Bod_Inst, Iterator, Iterator_Val); - end if; - - Synth_Declarations (Bod_Inst, Decls_Chain); + Synth_Concurrent_Declarations (Syn_Inst, Decls_Chain); Synth_Concurrent_Statements - (Bod_Inst, Get_Concurrent_Statement_Chain (Bod)); + (Syn_Inst, Get_Concurrent_Statement_Chain (Bod)); - Synth_Attribute_Values (Bod_Inst, Bod); + Synth_Attribute_Values (Syn_Inst, Bod); - Finalize_Declarations (Bod_Inst, Decls_Chain); + Finalize_Declarations (Syn_Inst, Decls_Chain); - Free_Instance (Bod_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Generate_Statement_Body; @@ -3552,34 +3532,17 @@ package body Synth.Vhdl_Stmts is procedure Synth_If_Generate_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node) is - Gen : Node; - Bod : Node; - Icond : Node; - Cond : Valtyp; + Sub_Inst : Synth_Instance_Acc; Name : Sname; - Config : Node; begin - Gen := Stmt; + Sub_Inst := Get_Sub_Instance (Syn_Inst, Stmt); + if Sub_Inst = null then + return; + end if; + Name := New_Sname_User (Get_Identifier (Stmt), Get_Sname (Syn_Inst)); - loop - Icond := Get_Condition (Gen); - if Icond /= Null_Node then - Cond := Synth_Expression (Syn_Inst, Icond); - Strip_Const (Cond); - else - -- It is the else generate. - Cond := No_Valtyp; - end if; - if Cond = No_Valtyp or else Read_Discrete (Cond) = 1 then - Bod := Get_Generate_Statement_Body (Gen); - Config := Get_Generate_Block_Configuration (Bod); - Apply_Block_Configuration (Config, Bod); - Synth_Generate_Statement_Body (Syn_Inst, Bod, Name); - exit; - end if; - Gen := Get_Generate_Else_Clause (Gen); - exit when Gen = Null_Node; - end loop; + Set_Extra (Sub_Inst, Syn_Inst, Name); + Synth_Generate_Statement_Body (Sub_Inst, Get_Source_Scope (Sub_Inst)); end Synth_If_Generate_Statement; procedure Synth_For_Generate_Statement @@ -3587,48 +3550,26 @@ package body Synth.Vhdl_Stmts is is Iterator : constant Node := Get_Parameter_Specification (Stmt); Bod : constant Node := Get_Generate_Statement_Body (Stmt); - Configs : constant Node := Get_Generate_Block_Configuration (Bod); - It_Type : constant Node := Get_Declaration_Type (Iterator); - Config : Node; It_Rng : Type_Acc; - Val : Valtyp; + Sub_Inst : Synth_Instance_Acc; + Gen_Inst : Synth_Instance_Acc; Name : Sname; Lname : Sname; begin - if It_Type /= Null_Node then - Synth_Subtype_Indication (Syn_Inst, It_Type); - end if; - - -- Initial value. It_Rng := Get_Subtype_Object (Syn_Inst, Get_Type (Iterator)); - Val := Create_Value_Discrete (It_Rng.Drange.Left, It_Rng); + Gen_Inst := Get_Sub_Instance (Syn_Inst, Stmt); Name := New_Sname_User (Get_Identifier (Stmt), Get_Sname (Syn_Inst)); + Set_Extra (Gen_Inst, Syn_Inst, Name); - while In_Range (It_Rng.Drange, Read_Discrete (Val)) loop - -- Find and apply the config block. - declare - Spec : Node; - begin - Config := Configs; - while Config /= Null_Node loop - Spec := Get_Block_Specification (Config); - case Get_Kind (Spec) is - when Iir_Kind_Simple_Name => - exit; - when others => - Error_Kind ("synth_for_generate_statement", Spec); - end case; - Config := Get_Prev_Block_Configuration (Config); - end loop; - Apply_Block_Configuration (Config, Bod); - end; - + for I in 1 .. Get_Range_Length (It_Rng.Drange) loop -- FIXME: get position ? - Lname := New_Sname_Version (Uns32 (Read_Discrete (Val)), Name); + Lname := New_Sname_Version (Uns32 (I), Name); + + Sub_Inst := Get_Generate_Sub_Instance (Gen_Inst, Positive (I)); + Set_Extra (Sub_Inst, Gen_Inst, Lname); - Synth_Generate_Statement_Body (Syn_Inst, Bod, Lname, Iterator, Val); - Update_Index (It_Rng.Drange, Val); + Synth_Generate_Statement_Body (Sub_Inst, Bod); end loop; end Synth_For_Generate_Statement; @@ -3663,10 +3604,14 @@ package body Synth.Vhdl_Stmts is when Iir_Kind_Component_Instantiation_Statement => if Is_Component_Instantiation (Stmt) then declare + Comp_Inst : constant Synth_Instance_Acc := + Get_Sub_Instance (Syn_Inst, Stmt); Comp_Config : constant Node := - Get_Component_Configuration (Stmt); + Get_Instance_Config (Comp_Inst); begin - if Get_Binding_Indication (Comp_Config) = Null_Node then + if Comp_Config = Null_Node + or else Get_Binding_Indication (Comp_Config) = Null_Node + then -- Not bound. Synth_Blackbox_Instantiation_Statement (Syn_Inst, Stmt); else @@ -3766,7 +3711,7 @@ package body Synth.Vhdl_Stmts is N := Build_Formal_Input (Get_Build (Syn_Inst), Id, Typ.W); Set_Location (N, Val); - Add_Conc_Assign (Base.Val.W, N, 0); + Add_Conc_Assign (Get_Value_Wire (Base.Val), N, 0); end; end Synth_Attribute_Formal; @@ -3803,27 +3748,22 @@ package body Synth.Vhdl_Stmts is end loop; end Synth_Attribute_Values; - procedure Synth_Verification_Unit - (Syn_Inst : Synth_Instance_Acc; Unit : Node) + procedure Synth_Verification_Unit (Syn_Inst : Synth_Instance_Acc; + Unit : Node; + Parent_Inst : Synth_Instance_Acc) is use Areapools; Prev_Instance_Pool : constant Areapool_Acc := Instance_Pool; - Unit_Inst : Synth_Instance_Acc; Unit_Sname : Sname; M : Areapools.Mark_Type; Item : Node; - Last_Type : Node; begin Unit_Sname := New_Sname_User (Get_Identifier (Unit), Get_Sname (Syn_Inst)); - Unit_Inst := Make_Instance (Syn_Inst, Unit, Unit_Sname); + Set_Extra (Syn_Inst, Parent_Inst, Unit_Sname); Mark (M, Proc_Pool); Instance_Pool := Proc_Pool'Access; - Apply_Block_Configuration - (Get_Verification_Block_Configuration (Unit), Unit); - - Last_Type := Null_Node; Item := Get_Vunit_Item_Chain (Unit); while Item /= Null_Node loop case Get_Kind (Item) is @@ -3831,13 +3771,13 @@ package body Synth.Vhdl_Stmts is | Iir_Kind_Psl_Declaration => null; when Iir_Kind_Psl_Assert_Directive => - Synth_Psl_Assert_Directive (Unit_Inst, Item); + Synth_Psl_Assert_Directive (Syn_Inst, Item); when Iir_Kind_Psl_Assume_Directive => - Synth_Psl_Assume_Directive (Unit_Inst, Item); + Synth_Psl_Assume_Directive (Syn_Inst, Item); when Iir_Kind_Psl_Restrict_Directive => - Synth_Psl_Restrict_Directive (Unit_Inst, Item); + Synth_Psl_Restrict_Directive (Syn_Inst, Item); when Iir_Kind_Psl_Cover_Directive => - Synth_Psl_Cover_Directive (Unit_Inst, Item); + Synth_Psl_Cover_Directive (Syn_Inst, Item); when Iir_Kind_Signal_Declaration | Iir_Kind_Constant_Declaration | Iir_Kind_Function_Declaration @@ -3846,21 +3786,21 @@ package body Synth.Vhdl_Stmts is | Iir_Kind_Procedure_Body | Iir_Kind_Attribute_Declaration | Iir_Kind_Attribute_Specification => - Synth_Declaration (Unit_Inst, Item, False, Last_Type); + Synth_Concurrent_Declaration (Syn_Inst, Item); when Iir_Kinds_Concurrent_Signal_Assignment | Iir_Kinds_Process_Statement | Iir_Kinds_Generate_Statement | Iir_Kind_Block_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Component_Instantiation_Statement => - Synth_Concurrent_Statement (Unit_Inst, Item); + Synth_Concurrent_Statement (Syn_Inst, Item); when others => Error_Kind ("synth_verification_unit", Item); end case; Item := Get_Chain (Item); end loop; - Synth_Attribute_Values (Unit_Inst, Unit); + Synth_Attribute_Values (Syn_Inst, Unit); -- Finalize Item := Get_Vunit_Item_Chain (Unit); @@ -3888,14 +3828,13 @@ package body Synth.Vhdl_Stmts is | Iir_Kind_Procedure_Body | Iir_Kind_Attribute_Declaration | Iir_Kind_Attribute_Specification => - Finalize_Declaration (Unit_Inst, Item, False); + Finalize_Declaration (Syn_Inst, Item, False); when others => Error_Kind ("synth_verification_unit(2)", Item); end case; Item := Get_Chain (Item); end loop; - Free_Instance (Unit_Inst); Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Verification_Unit; diff --git a/src/synth/synth-vhdl_stmts.ads b/src/synth/synth-vhdl_stmts.ads index 9621a7c9f..a7a2c719c 100644 --- a/src/synth/synth-vhdl_stmts.ads +++ b/src/synth/synth-vhdl_stmts.ads @@ -19,11 +19,12 @@ with Types; use Types; with Vhdl.Nodes; use Vhdl.Nodes; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; +with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; +with Elab.Vhdl_Values; use Elab.Vhdl_Values; + with Netlists; use Netlists; -with Synth.Objtypes; use Synth.Objtypes; -with Synth.Values; use Synth.Values; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; package Synth.Vhdl_Stmts is @@ -90,12 +91,9 @@ package Synth.Vhdl_Stmts is procedure Synth_Attribute_Values (Syn_Inst : Synth_Instance_Acc; Unit : Node); - procedure Synth_Verification_Unit - (Syn_Inst : Synth_Instance_Acc; Unit : Node); - - -- For iterators. - procedure Update_Index (Rng : Discrete_Range_Type; V : in out Valtyp); - + procedure Synth_Verification_Unit (Syn_Inst : Synth_Instance_Acc; + Unit : Node; + Parent_Inst : Synth_Instance_Acc); private -- There are 2 execution mode: -- * static: it is like simulation, all the inputs are known, neither diff --git a/src/synth/synthesis.adb b/src/synth/synthesis.adb index d10d431d5..57d20df13 100644 --- a/src/synth/synthesis.adb +++ b/src/synth/synthesis.adb @@ -23,12 +23,10 @@ with Netlists.Cleanup; with Netlists.Memories; with Netlists.Expands; -with Synth.Objtypes; -with Synth.Vhdl_Insts; use Synth.Vhdl_Insts; - +with Elab.Vhdl_Values.Debug; +pragma Unreferenced (Elab.Vhdl_Values.Debug); -with Synth.Values.Debug; -pragma Unreferenced (Synth.Values.Debug); +with Synth.Vhdl_Insts; use Synth.Vhdl_Insts; package body Synthesis is function Make_Base_Instance return Base_Instance_Acc @@ -47,17 +45,14 @@ package body Synthesis is return Base; end Make_Base_Instance; - procedure Synth_Design (Design : Node; - Encoding : Name_Encoding; - M : out Module; - Inst : out Synth_Instance_Acc) + function Synth_Design (Design : Iir; + Inst : Synth_Instance_Acc; + Encoding : Name_Encoding) return Module is Base : Base_Instance_Acc; begin Base := Make_Base_Instance; - Synth.Objtypes.Init; - case Iir_Kinds_Design_Unit (Get_Kind (Design)) is when Iir_Kind_Foreign_Module => if Synth_Top_Foreign = null then @@ -71,11 +66,10 @@ package body Synthesis is Synth.Vhdl_Insts.Synth_All_Instances; if Errorout.Nbr_Errors > 0 then - M := No_Module; - return; + return No_Module; end if; - M := Base.Top_Module; + return Base.Top_Module; end Synth_Design; procedure Instance_Passes (Ctxt : Context_Acc; M : Module) is diff --git a/src/synth/synthesis.ads b/src/synth/synthesis.ads index 59688832e..30523c21d 100644 --- a/src/synth/synthesis.ads +++ b/src/synth/synthesis.ads @@ -22,15 +22,15 @@ with Vhdl.Nodes; use Vhdl.Nodes; with Netlists; use Netlists; with Netlists.Builders; use Netlists.Builders; +with Elab.Vhdl_Context; use Elab.Vhdl_Context; + with Synth.Context; use Synth.Context; -with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Flags; use Synth.Flags; package Synthesis is - procedure Synth_Design (Design : Iir; - Encoding : Name_Encoding; - M : out Module; - Inst : out Synth_Instance_Acc); + function Synth_Design (Design : Iir; + Inst : Synth_Instance_Acc; + Encoding : Name_Encoding) return Module; -- Run cleanup/memory extraction/expand passes on M. procedure Instance_Passes (Ctxt : Context_Acc; M : Module); -- cgit v1.2.3