diff options
author | Tristan Gingold <tgingold@free.fr> | 2017-01-30 21:09:19 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2017-01-31 20:22:08 +0100 |
commit | bc10b035f5998d1cc9ec2aa0122ee1c24099ca05 (patch) | |
tree | 56e0e2fc8733caa1fff39a3cce9fd205b307f575 | |
parent | 3a412a309bcea39e5c8ecd094711bc70452a1e73 (diff) | |
download | ghdl-bc10b035f5998d1cc9ec2aa0122ee1c24099ca05.tar.gz ghdl-bc10b035f5998d1cc9ec2aa0122ee1c24099ca05.tar.bz2 ghdl-bc10b035f5998d1cc9ec2aa0122ee1c24099ca05.zip |
Add netlist generation infrastructure.
44 files changed, 7531 insertions, 0 deletions
diff --git a/src/ghdldrv/ghdlsynth.adb b/src/ghdldrv/ghdlsynth.adb new file mode 100644 index 000000000..0ae4eff87 --- /dev/null +++ b/src/ghdldrv/ghdlsynth.adb @@ -0,0 +1,118 @@ +-- GHDL driver for synthesis +-- Copyright (C) 2016 Tristan Gingold +-- +-- GHDL 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, or (at your option) any later +-- version. +-- +-- GHDL 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ghdllocal; use Ghdllocal; +with Ghdlcomp; +with Ghdlmain; +with Ghdlsimul; + +with Libraries; +with Flags; +with Canon; + +with Elaboration; + +with Synthesis; +with Netlists.Dump; + +package body Ghdlsynth is + -- Command --synth + type Command_Synth is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Synth; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Synth) return String; + + procedure Perform_Action (Cmd : in out Command_Synth; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Synth; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--synth"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Synth) return String + is + pragma Unreferenced (Cmd); + begin + return "--synth [FILES... -e] UNIT [ARCH] Synthesis from UNIT"; + end Get_Short_Help; + + function Ghdl_Synth (Args : Argument_List) return Netlists.Module + is + E_Opt : Integer; + Opt_Arg : Natural; + begin + -- If the '-e' switch is present, there is a list of files. + E_Opt := Args'First - 1; + for I in Args'Range loop + if Args (I).all = "-e" then + E_Opt := I; + exit; + end if; + end loop; + + Ghdlcomp.Hooks.Compile_Init.all (False); + Flags.Flag_Elaborate_With_Outdated := False; + Flags.Flag_Only_Elab_Warnings := True; + + Libraries.Load_Work_Library (E_Opt >= Args'First); + + -- Do not canon concurrent statements. + Canon.Canon_Flag_Concurrent_Stmts := False; + + Canon.Canon_Flag_Add_Labels := True; + + -- Analyze files (if any) + for I in Args'First .. E_Opt - 1 loop + Ghdlcomp.Compile_Analyze_File (Args (I).all); + end loop; + + -- Elaborate + Ghdlcomp.Hooks.Compile_Elab.all + ("--synth", Args (E_Opt + 1 .. Args'Last), Opt_Arg); + + if Opt_Arg <= Args'Last then + Ghdlmain.Error ("extra options ignored"); + end if; + + -- Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last)); + + Elaboration.Elaborate_Design (Ghdlsimul.Get_Top_Config); + + return Synthesis.Synth_Design (Ghdlsimul.Get_Top_Config); + -- Hooks.Run.all; + end Ghdl_Synth; + + procedure Perform_Action (Cmd : in out Command_Synth; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Res : Netlists.Module; + begin + Res := Ghdl_Synth (Args); + Netlists.Dump.Disp_Module (Res); + end Perform_Action; + + procedure Register_Commands is + begin + Ghdlmain.Register_Command (new Command_Synth); + end Register_Commands; +end Ghdlsynth; diff --git a/src/ghdldrv/ghdlsynth.ads b/src/ghdldrv/ghdlsynth.ads new file mode 100644 index 000000000..f9a755c08 --- /dev/null +++ b/src/ghdldrv/ghdlsynth.ads @@ -0,0 +1,25 @@ +-- GHDL driver for synthesis +-- Copyright (C) 2016 Tristan Gingold +-- +-- GHDL 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, or (at your option) any later +-- version. +-- +-- GHDL 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Netlists; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Ghdlsynth is + procedure Register_Commands; + + function Ghdl_Synth (Args : Argument_List) return Netlists.Module; +end Ghdlsynth; diff --git a/src/synth/build_header.sh b/src/synth/build_header.sh new file mode 100644 index 000000000..5733bd2d3 --- /dev/null +++ b/src/synth/build_header.sh @@ -0,0 +1,8 @@ +#!/bin/sh + +{ +echo "/* This file is automatically generated by build_header.sh - DO NOT MODIFY */" +echo "enum Module_Id {" +grep -h "constant Module_Id :=" netlists.ads netlists-gates.ads | sed -e '/constant Module_Id :=/s/:.*://' -e 's/;/,/' -e 's/ *--.*$//' +echo "};" +} > ghdlsynth_gates.h diff --git a/src/synth/ghdlsynth.h b/src/synth/ghdlsynth.h new file mode 100644 index 000000000..f2a7f095c --- /dev/null +++ b/src/synth/ghdlsynth.h @@ -0,0 +1,129 @@ +/* Ghdlsynth -*- C++ -*- interface + + This file is part of GHDL. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, + MA 02110-1301, USA. */ + +namespace GhdlSynth { + // Use struct wrappers for type safety. +#define GHDLSYNTH_ADA_PREFIX(N) netlists__##N +#define GHDLSYNTH_ADA_WRAPPER_WD(NAME, RESTYPE, ARGTYPE) \ + extern "C" unsigned int GHDLSYNTH_ADA_PREFIX(NAME) (unsigned int); \ + inline RESTYPE NAME(ARGTYPE arg) { \ + RESTYPE res; \ + res.id = GHDLSYNTH_ADA_PREFIX(NAME) (arg.id); \ + return res; \ + } + +#define GHDLSYNTH_ADA_WRAPPER_WWD(NAME, RESTYPE, ARGTYPE1, ARGTYPE2) \ + extern "C" unsigned int GHDLSYNTH_ADA_PREFIX(NAME) (unsigned int, ARGTYPE2);\ + inline RESTYPE NAME(ARGTYPE1 arg1, ARGTYPE2 arg2) { \ + RESTYPE res; \ + res.id = GHDLSYNTH_ADA_PREFIX(NAME) (arg1.id, arg2); \ + return res; \ + } + +#define GHDLSYNTH_ADA_WRAPPER_DWD(NAME, RESTYPE, ARGTYPE1, ARGTYPE2) \ + extern "C" unsigned int GHDLSYNTH_ADA_PREFIX(NAME) (unsigned int, ARGTYPE2);\ + inline RESTYPE NAME(ARGTYPE1 arg1, ARGTYPE2 arg2) { \ + return GHDLSYNTH_ADA_PREFIX(NAME) (arg1.id, arg2); \ + } + +#define GHDLSYNTH_ADA_WRAPPER_DW(NAME, RESTYPE, ARGTYPE) \ + extern "C" RESTYPE GHDLSYNTH_ADA_PREFIX(NAME) (unsigned int); \ + inline RESTYPE NAME(ARGTYPE arg) { \ + return GHDLSYNTH_ADA_PREFIX(NAME) (arg.id); \ + } + +#define GHDLSYNTH_ADA_WRAPPER_BW(NAME, ARGTYPE) \ + extern "C" unsigned int GHDLSYNTH_ADA_PREFIX(NAME) (unsigned int); \ + inline bool NAME(ARGTYPE arg) { \ + return (GHDLSYNTH_ADA_PREFIX(NAME) (arg.id) & 1); \ + } + + struct Name_Id { unsigned int id; }; + extern "C" const char *name_table__get_address (unsigned int); + inline const char *get_cstr(Name_Id n) { + return name_table__get_address (n.id); + } + + struct Sname { unsigned int id; }; + const Sname No_Sname = {0 }; + + enum Sname_Kind { Sname_User, Sname_Artificial, Sname_Version }; + GHDLSYNTH_ADA_WRAPPER_DW(get_sname_kind, Sname_Kind, Sname); + inline bool is_valid(Sname l) { return l.id != 0; } + + GHDLSYNTH_ADA_WRAPPER_WD(get_sname_prefix, Sname, Sname); + GHDLSYNTH_ADA_WRAPPER_WD(get_sname_suffix, Name_Id, Sname); + + GHDLSYNTH_ADA_WRAPPER_DW(get_sname_version, unsigned int, Sname); + + typedef unsigned int Width; + typedef unsigned int Port_Idx; + typedef unsigned int Param_Idx; + +#include "ghdlsynth_gates.h" + + struct Module { unsigned int id; }; + inline bool is_valid(Module m) { return m.id != 0; } + GHDLSYNTH_ADA_WRAPPER_WD(get_module_name, Sname, Module); + GHDLSYNTH_ADA_WRAPPER_WD(get_first_sub_module, Module, Module); + GHDLSYNTH_ADA_WRAPPER_WD(get_next_sub_module, Module, Module); + GHDLSYNTH_ADA_WRAPPER_DW(get_id, Module_Id, Module); + GHDLSYNTH_ADA_WRAPPER_DW(get_nbr_outputs, unsigned int, Module); + GHDLSYNTH_ADA_WRAPPER_DW(get_nbr_inputs, unsigned int, Module); + + struct Net { unsigned int id; }; + GHDLSYNTH_ADA_WRAPPER_DW(get_width, Width, Net); + + struct Instance { unsigned int id; }; + inline bool is_valid(Instance inst) { return inst.id != 0; } + GHDLSYNTH_ADA_WRAPPER_WD(get_self_instance, Instance, Module); + GHDLSYNTH_ADA_WRAPPER_WD(get_first_instance, Instance, Module); + GHDLSYNTH_ADA_WRAPPER_WD(get_next_instance, Instance, Instance); + GHDLSYNTH_ADA_WRAPPER_WD(get_instance_name, Sname, Instance); + GHDLSYNTH_ADA_WRAPPER_WD(get_module, Module, Instance); + GHDLSYNTH_ADA_WRAPPER_WD(get_net_parent, Instance, Net); + GHDLSYNTH_ADA_WRAPPER_DWD(get_param_uns32, unsigned int, Instance, Port_Idx); + + struct Input { unsigned int id; }; + GHDLSYNTH_ADA_WRAPPER_WWD(get_input, Input, Instance, Port_Idx); + GHDLSYNTH_ADA_WRAPPER_WWD(get_output, Net, Instance, Port_Idx); + GHDLSYNTH_ADA_WRAPPER_WD(get_driver, Net, Input); + + // Utils +#undef GHDLSYNTH_ADA_PREFIX +#define GHDLSYNTH_ADA_PREFIX(N) netlists__utils__##N + GHDLSYNTH_ADA_WRAPPER_DW(get_id, Module_Id, Instance); + GHDLSYNTH_ADA_WRAPPER_WWD(get_input_name, Sname, Module, Port_Idx); + GHDLSYNTH_ADA_WRAPPER_WWD(get_output_name, Sname, Module, Port_Idx); + GHDLSYNTH_ADA_WRAPPER_BW(has_one_connection, Net); + + extern "C" unsigned int libghdlsynth__synth(int argc, const char **argv); + inline Module ghdl_synth(int argc, const char **argv) { + Module res; + res.id = libghdlsynth__synth(argc, argv); + return res; + } + + // Disp ghdl configuration. + extern "C" void ghdlcomp__disp_config (void); + + // Initialize and finalize the whole library. + extern "C" void libghdlsynth_init (void); + extern "C" void libghdlsynth_final (void); +}; diff --git a/src/synth/ghdlsynth_gates.h b/src/synth/ghdlsynth_gates.h new file mode 100644 index 000000000..b101ce691 --- /dev/null +++ b/src/synth/ghdlsynth_gates.h @@ -0,0 +1,60 @@ +enum Module_Id { + Id_None = 0, + Id_Free = 1, + Id_Design = 2, + Id_User_None = 128, + Id_User_First = Id_User_None + 1, + Id_And = 3, + Id_Or = 4, + Id_Xor = 5, + Id_Nand = 6, + Id_Nor = 7, + Id_Xnor = 8, + Id_Add = 9, + Id_Sub = 10, + Id_Mul = 11, + Id_Buf = 13, + Id_Not = 14, + Id_Neg = 15, + Id_Eq = 16, + Id_Ne = 17, + Id_Ule = 18, + Id_Sle = 19, + Id_Ult = 18, + Id_Slt = 19, + Id_Uge = 18, + Id_Sge = 19, + Id_Ugt = 18, + Id_Sgt = 19, + Id_Red_And = 20, + Id_Red_Or = 21, + Id_Concat2 = 22, + Id_Concat3 = 23, + Id_Concat4 = 24, + Id_Split2 = 25, + Id_Split3 = 26, + Id_Mux2 = 27, + Id_Mux4 = 28, + Id_Signal = 29, + Id_Isignal = 30, + Id_Output = 31, + Id_Dff = 32, + Id_Adff = 33, + Id_Idff = 34, + Id_Iadff = 35, + Id_Utrunc = 40, + Id_Strunc = 41, + Id_Uextend = 42, + Id_Sextend = 43, + Id_Extract = 44, + Id_Posedge = 50, + Id_Negedge = 51, + Id_Const_UB32 = 56, + Id_Const_SB32 = 57, + Id_Const_UB64 = 58, + Id_Const_SB64 = 59, + Id_Const_UB128 = 60, + Id_Const_SB128 = 61, + Id_Const_UL32 = 62, + Id_Const_SL32 = 63, +}; diff --git a/src/synth/libghdlsynth.adb b/src/synth/libghdlsynth.adb new file mode 100644 index 000000000..683bfffad --- /dev/null +++ b/src/synth/libghdlsynth.adb @@ -0,0 +1,47 @@ +-- Ghdlsynth as a library. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ghdlsynth; +with Ghdlsimul; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body Libghdlsynth is + function Synth (Argc : Natural; Argv : C_String_Array_Acc) return Module + is + Args : Argument_List (1 .. Argc); + Res : Module; + begin + for I in 0 .. Argc - 1 loop + declare + Arg : constant Ghdl_C_String := Argv (I); + begin + Args (I + 1) := new String'(Arg (1 .. strlen (Arg))); + end; + end loop; + Res := Ghdlsynth.Ghdl_Synth (Args); + + return Res; + end Synth; + + Gnat_Version : constant String := "unknown compiler version" & ASCII.NUL; + pragma Export (C, Gnat_Version, "__gnat_version"); +begin + Ghdlsimul.Compile_Init; +end Libghdlsynth; diff --git a/src/synth/libghdlsynth.ads b/src/synth/libghdlsynth.ads new file mode 100644 index 000000000..0824dea69 --- /dev/null +++ b/src/synth/libghdlsynth.ads @@ -0,0 +1,29 @@ +-- Ghdlsynth as a library. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Grt.Types; use Grt.Types; +with Netlists; use Netlists; + +package Libghdlsynth is + type C_String_Array is array (Natural) of Ghdl_C_String; + type C_String_Array_Acc is access C_String_Array; + + function Synth (Argc : Natural; Argv : C_String_Array_Acc) return Module; +end Libghdlsynth; diff --git a/src/synth/netlists-builders.adb b/src/synth/netlists-builders.adb new file mode 100644 index 000000000..5fb5140fa --- /dev/null +++ b/src/synth/netlists-builders.adb @@ -0,0 +1,649 @@ +-- API to build a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Name_Table; use Name_Table; +with Std_Names; use Std_Names; + +package body Netlists.Builders is + function Create_Input (Id : String; W : Width := 0) return Port_Desc is + begin + return (Name => New_Sname_Artificial (Get_Identifier (Id)), + W => W, + Dir => Port_In, + Left | Right => 0); + end Create_Input; + + function Create_Output (Id : String; W : Width := 0) return Port_Desc is + begin + return (Name => New_Sname_Artificial (Get_Identifier (Id)), + W => W, + Dir => Port_Out, + Left | Right => 0); + end Create_Output; + + procedure Create_Dyadic_Module (Design : Module; + Res : out Module; + Name : Name_Id; + Id : Module_Id) + is + Inputs : Port_Desc_Array (0 .. 1); + Outputs : Port_Desc_Array (0 .. 0); + begin + Res := New_User_Module (Design, New_Sname_Artificial (Name), + Id, 2, 1, 0); + Inputs := (0 => Create_Input ("a"), + 1 => Create_Input ("b")); + Outputs := (0 => Create_Output ("o")); + Set_Port_Desc (Res, Inputs, Outputs); + end Create_Dyadic_Module; + + procedure Create_Monadic_Module (Design : Module; + Res : out Module; + Name : Name_Id; + Id : Module_Id) + is + Inputs : Port_Desc_Array (0 .. 0); + Outputs : Port_Desc_Array (0 .. 0); + begin + Res := New_User_Module (Design, New_Sname_Artificial (Name), + Id, 1, 1, 0); + Inputs := (0 => Create_Input ("i")); + Outputs := (0 => Create_Output ("o")); + Set_Port_Desc (Res, Inputs, Outputs); + end Create_Monadic_Module; + + procedure Create_Compare_Module (Design : Module; + Res : out Module; + Name : Name_Id; + Id : Module_Id) + is + Inputs : Port_Desc_Array (0 .. 1); + Outputs : Port_Desc_Array (0 .. 0); + begin + Res := New_User_Module (Design, New_Sname_Artificial (Name), + Id, 2, 1, 0); + Inputs := (0 => Create_Input ("a"), + 1 => Create_Input ("b")); + Outputs := (0 => Create_Output ("o", 1)); + Set_Port_Desc (Res, Inputs, Outputs); + end Create_Compare_Module; + + procedure Create_Concat_Modules (Ctxt : Context_Acc) + is + Inputs : Port_Desc_Array (0 .. 3); + Outputs : Port_Desc_Array (0 .. 0); + Res : Module; + begin + Inputs := (0 => Create_Input ("i1"), + 1 => Create_Input ("i2"), + 2 => Create_Input ("i3"), + 3 => Create_Input ("i4")); + Outputs := (0 => Create_Output ("o")); + + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("concat2")), + Id_Concat2, 2, 1, 0); + Ctxt.M_Concat (Id_Concat2) := Res; + Set_Port_Desc (Res, Inputs (0 .. 1), Outputs); + + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("concat3")), + Id_Concat3, 3, 1, 0); + Ctxt.M_Concat (Id_Concat3) := Res; + Set_Port_Desc (Res, Inputs (0 .. 2), Outputs); + + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("concat4")), + Id_Concat4, 4, 1, 0); + Ctxt.M_Concat (Id_Concat4) := Res; + Set_Port_Desc (Res, Inputs (0 .. 3), Outputs); + end Create_Concat_Modules; + + procedure Create_Const_Modules (Ctxt : Context_Acc) + is + Outputs : Port_Desc_Array (0 .. 0); + Res : Module; + begin + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("const_UB32")), + Id_Const_UB32, 0, 1, 1); + Ctxt.M_Const_UB32 := Res; + Outputs := (0 => Create_Output ("o")); + Set_Port_Desc (Res, Port_Desc_Array'(1 .. 0 => <>), Outputs); + Set_Param_Desc + (Res, (0 => (New_Sname_Artificial (Get_Identifier ("val")), + Typ => Param_Uns32))); + + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("const_UL32")), + Id_Const_UL32, 0, 1, 2); + Ctxt.M_Const_UL32 := Res; + Set_Port_Desc (Res, Port_Desc_Array'(1 .. 0 => <>), Outputs); + Set_Param_Desc + (Res, (0 => (New_Sname_Artificial (Get_Identifier ("val")), + Typ => Param_Uns32), + 1 => (New_Sname_Artificial (Get_Identifier ("xz")), + Typ => Param_Uns32))); + end Create_Const_Modules; + + procedure Create_Extract_Module (Ctxt : Context_Acc) + is + Outputs : Port_Desc_Array (0 .. 0); + Inputs : Port_Desc_Array (0 .. 0); + Res : Module; + begin + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("extract")), + Id_Extract, 1, 1, 1); + Ctxt.M_Extract := Res; + Outputs := (0 => Create_Output ("o")); + Inputs := (0 => Create_Input ("i")); + Set_Port_Desc (Res, Inputs, Outputs); + Set_Param_Desc + (Res, (0 => (New_Sname_Artificial (Get_Identifier ("offset")), + Typ => Param_Uns32))); + end Create_Extract_Module; + + procedure Create_Edge_Module (Ctxt : Context_Acc; + Res : out Module; + Name : Name_Id; + Id : Module_Id) + + is + Outputs : Port_Desc_Array (0 .. 0); + Inputs : Port_Desc_Array (0 .. 0); + begin + Res := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Name), Id, 1, 1, 0); + Inputs := (0 => Create_Input ("i", 1)); + Outputs := (0 => Create_Output ("o", 1)); + Set_Port_Desc (Res, Inputs, Outputs); + end Create_Edge_Module; + + procedure Create_Mux_Modules (Ctxt : Context_Acc) + is + Outputs : Port_Desc_Array (0 .. 0); + Inputs : Port_Desc_Array (0 .. 4); + begin + Inputs := (0 => Create_Input ("s", 1), + 1 => Create_Input ("i0"), + 2 => Create_Input ("i1"), + 3 => Create_Input ("i2"), + 4 => Create_Input ("i3")); + Outputs := (0 => Create_Output ("o")); + + Ctxt.M_Mux2 := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("mux2")), + Id_Mux2, 3, 1, 0); + Set_Port_Desc (Ctxt.M_Mux2, Inputs (0 .. 2), Outputs); + + Ctxt.M_Mux4 := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("mux4")), + Id_Mux4, 5, 1, 0); + Set_Port_Desc (Ctxt.M_Mux4, Inputs (0 .. 4), Outputs); + end Create_Mux_Modules; + + procedure Create_Objects_Module (Ctxt : Context_Acc) + is + Outputs : Port_Desc_Array (0 .. 0); + Inputs : Port_Desc_Array (0 .. 0); + Inputs2 : Port_Desc_Array (0 .. 1); + begin + Inputs := (0 => Create_Input ("i")); + Outputs := (0 => Create_Output ("o")); + + Ctxt.M_Output := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("output")), + Id_Output, 1, 1, 0); + Set_Port_Desc (Ctxt.M_Output, Inputs, Outputs); + + Ctxt.M_Signal := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("signal")), + Id_Signal, 1, 1, 0); + Set_Port_Desc (Ctxt.M_Signal, Inputs, Outputs); + + + Inputs2 := (0 => Create_Input ("i"), + 1 => Create_Input ("init")); + Ctxt.M_Isignal := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("isignal")), + Id_Isignal, 2, 1, 0); + Set_Port_Desc (Ctxt.M_Isignal, Inputs2, Outputs); + end Create_Objects_Module; + + procedure Create_Dff_Modules (Ctxt : Context_Acc) + is + Outputs : Port_Desc_Array (0 .. 0); + begin + Ctxt.M_Dff := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("dff")), + Id_Dff, 2, 1, 0); + Outputs := (0 => Create_Output ("q")); + Set_Port_Desc (Ctxt.M_Dff, (0 => Create_Input ("clk", 1), + 1 => Create_Input ("d")), + Outputs); + + Ctxt.M_Idff := New_User_Module + (Ctxt.Design, New_Sname_Artificial (Get_Identifier ("idff")), + Id_Idff, 3, 1, 0); + Set_Port_Desc (Ctxt.M_Idff, (0 => Create_Input ("clk", 1), + 1 => Create_Input ("d"), + 2 => Create_Input ("init")), + Outputs); + end Create_Dff_Modules; + + function Build_Builders (Design : Module) return Context_Acc + is + Res : Context_Acc; + begin + Res := new Context'(Design => Design, + Parent => No_Module, + Num => 0, + M_Dyadic => (others => No_Module), + M_Monadic => (others => No_Module), + M_Compare => (others => No_Module), + M_Concat => (others => No_Module), + M_Truncate | M_Extend => (others => No_Module), + others => No_Module); + + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_And), Name_And, Id_And); + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_Or), Name_Or, Id_Or); + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_Xor), Name_Xor, Id_Xor); + + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_Add), + Get_Identifier ("add"), Id_Add); + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_Sub), + Get_Identifier ("sub"), Id_Sub); + Create_Dyadic_Module (Design, Res.M_Dyadic (Id_Mul), + Get_Identifier ("mul"), Id_Mul); + + Create_Monadic_Module (Design, Res.M_Monadic (Id_Not), Name_Not, Id_Not); + + Create_Compare_Module (Design, Res.M_Compare (Id_Eq), + Get_Identifier ("eq"), Id_Eq); + Create_Compare_Module (Design, Res.M_Compare (Id_Ne), + Get_Identifier ("ne"), Id_Ne); + + Create_Concat_Modules (Res); + Create_Const_Modules (Res); + + Create_Extract_Module (Res); + + Create_Monadic_Module (Design, Res.M_Truncate (Id_Utrunc), + Get_Identifier ("utrunc"), Id_Utrunc); + Create_Monadic_Module (Design, Res.M_Truncate (Id_Strunc), + Get_Identifier ("strunc"), Id_Strunc); + + Create_Monadic_Module (Design, Res.M_Extend (Id_Uextend), + Get_Identifier ("uextend"), Id_Uextend); + Create_Monadic_Module (Design, Res.M_Extend (Id_Sextend), + Get_Identifier ("sextend"), Id_Sextend); + + Create_Edge_Module (Res, Res.M_Posedge, Name_Posedge, Id_Posedge); + Create_Edge_Module (Res, Res.M_Negedge, Name_Negedge, Id_Negedge); + + Create_Mux_Modules (Res); + Create_Objects_Module (Res); + Create_Dff_Modules (Res); + + return Res; + end Build_Builders; + + procedure Set_Parent (Ctxt : Context_Acc; Parent : Module) is + begin + Ctxt.Parent := Parent; + end Set_Parent; + + function New_Internal_Instance (Ctxt : Context_Acc; M : Module) + return Instance + is + pragma Assert (M /= No_Module); + Name : Sname; + begin + Name := New_Sname_Version (Get_Name (Ctxt.Parent), Ctxt.Num); + Ctxt.Num := Ctxt.Num + 1; + return New_Instance (Ctxt.Parent, M, Name); + end New_Internal_Instance; + + function Build_Dyadic (Ctxt : Context_Acc; + Id : Dyadic_Module_Id; + L, R : Net) return Net + is + Wd : constant Width := Get_Width (L); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (R) = Wd); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Dyadic (Id)); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 0), L); + Connect (Get_Input (Inst, 1), R); + return O; + end Build_Dyadic; + + function Build_Monadic (Ctxt : Context_Acc; + Id : Monadic_Module_Id; + Op : Net) return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Monadic (Id)); + O := Get_Output (Inst, 0); + Set_Width (O, Get_Width (Op)); + Connect (Get_Input (Inst, 0), Op); + return O; + end Build_Monadic; + + function Build_Compare (Ctxt : Context_Acc; + Id : Compare_Module_Id; + L, R : Net) return Net + is + Wd : constant Width := Get_Width (L); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (R) = Wd); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Compare (Id)); + O := Get_Output (Inst, 0); + Connect (Get_Input (Inst, 0), L); + Connect (Get_Input (Inst, 1), R); + return O; + end Build_Compare; + + function Build_Const_UB32 (Ctxt : Context_Acc; + Val : Uns32; + W : Width) return Net + is + pragma Assert (W <= 32); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Const_UB32); + O := Get_Output (Inst, 0); + Set_Param_Uns32 (Inst, 0, Val); + Set_Width (O, W); + return O; + end Build_Const_UB32; + + function Build_Const_UL32 (Ctxt : Context_Acc; + Val : Uns32; + Xz : Uns32; + W : Width) return Net + is + pragma Assert (W <= 32); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Const_UL32); + O := Get_Output (Inst, 0); + Set_Param_Uns32 (Inst, 0, Val); + Set_Param_Uns32 (Inst, 1, Xz); + Set_Width (O, W); + return O; + end Build_Const_UL32; + + function Build_Edge (Ctxt : Context_Acc; + Is_Pos : Boolean; + Src : Net) return Net + is + pragma Assert (Get_Width (Src) = 1); + M : Module; + Inst : Instance; + O : Net; + begin + if Is_Pos then + M := Ctxt.M_Posedge; + else + M := Ctxt.M_Negedge; + end if; + Inst := New_Internal_Instance (Ctxt, M); + O := Get_Output (Inst, 0); + pragma Assert (Get_Width (O) = 1); + Connect (Get_Input (Inst, 0), Src); + return O; + end Build_Edge; + + function Build_Mux2 (Ctxt : Context_Acc; + Sel : Net; + I0, I1 : Net) return Net + is + Wd : constant Width := Get_Width (I0); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (I1) = Wd); + pragma Assert (Get_Width (Sel) = 1); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Mux2); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 0), Sel); + Connect (Get_Input (Inst, 1), I0); + Connect (Get_Input (Inst, 2), I1); + return O; + end Build_Mux2; + + function Build_Mux4 (Ctxt : Context_Acc; + Sel : Net; + I0, I1, I2, I3 : Net) return Net + is + Wd : constant Width := Get_Width (I0); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (I1) = Wd); + pragma Assert (Get_Width (I2) = Wd); + pragma Assert (Get_Width (I3) = Wd); + pragma Assert (Get_Width (Sel) = 2); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Mux4); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 0), Sel); + Connect (Get_Input (Inst, 1), I0); + Connect (Get_Input (Inst, 2), I1); + Connect (Get_Input (Inst, 3), I2); + Connect (Get_Input (Inst, 4), I3); + return O; + end Build_Mux4; + + function Build_Concat2 (Ctxt : Context_Acc; I0, I1 : Net) return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Concat (Id_Concat2)); + O := Get_Output (Inst, 0); + Set_Width (O, Get_Width (I0) + Get_Width (I1)); + Connect (Get_Input (Inst, 0), I0); + Connect (Get_Input (Inst, 1), I1); + return O; + end Build_Concat2; + + function Build_Concat3 (Ctxt : Context_Acc; I0, I1, I2 : Net) return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Concat (Id_Concat3)); + O := Get_Output (Inst, 0); + Set_Width (O, Get_Width (I0) + Get_Width (I1) + Get_Width (I2)); + Connect (Get_Input (Inst, 0), I0); + Connect (Get_Input (Inst, 1), I1); + Connect (Get_Input (Inst, 2), I2); + return O; + end Build_Concat3; + + function Build_Concat4 (Ctxt : Context_Acc; I0, I1, I2, I3 : Net) + return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Concat (Id_Concat4)); + O := Get_Output (Inst, 0); + Set_Width (O, Get_Width (I0) + Get_Width (I1) + + Get_Width (I2) + Get_Width (I3)); + Connect (Get_Input (Inst, 0), I0); + Connect (Get_Input (Inst, 1), I1); + Connect (Get_Input (Inst, 2), I2); + Connect (Get_Input (Inst, 3), I3); + return O; + end Build_Concat4; + + function Build_Trunc + (Ctxt : Context_Acc; Id : Module_Id; I : Net; W : Width) return Net + is + pragma Assert (Get_Width (I) > W); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Truncate (Id)); + O := Get_Output (Inst, 0); + Set_Width (O, W); + Connect (Get_Input (Inst, 0), I); + return O; + end Build_Trunc; + + function Build_Extend + (Ctxt : Context_Acc; Id : Module_Id; I : Net; W : Width) return Net + is + pragma Assert (Get_Width (I) < W); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Extend (Id)); + O := Get_Output (Inst, 0); + Set_Width (O, W); + Connect (Get_Input (Inst, 0), I); + return O; + end Build_Extend; + + function Build_Object (Ctxt : Context_Acc; M : Module; W : Width) return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, M); + O := Get_Output (Inst, 0); + Set_Width (O, W); + return O; + end Build_Object; + + function Build_Output (Ctxt : Context_Acc; W : Width) return Net is + begin + return Build_Object (Ctxt, Ctxt.M_Output, W); + end Build_Output; + + function Build_Signal (Ctxt : Context_Acc; Name : Sname; W : Width) + return Net + is + Inst : Instance; + O : Net; + begin + Inst := New_Instance (Ctxt.Parent, Ctxt.M_Signal, Name); + O := Get_Output (Inst, 0); + Set_Width (O, W); + return O; + end Build_Signal; + + function Build_Isignal (Ctxt : Context_Acc; Name : Sname; Init : Net) + return Net + is + Wd : constant Width := Get_Width (Init); + pragma Assert (Wd /= No_Width); + Inst : Instance; + O : Net; + begin + Inst := New_Instance (Ctxt.Parent, Ctxt.M_Isignal, Name); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 1), Init); + return O; + end Build_Isignal; + + function Build_Dff (Ctxt : Context_Acc; + Clk : Net; + D : Net) return Net + is + Wd : constant Width := Get_Width (D); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (Clk) = 1); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Dff); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 0), Clk); + Connect (Get_Input (Inst, 1), D); + return O; + end Build_Dff; + + function Build_Idff (Ctxt : Context_Acc; + Clk : Net; + D : Net; + Init : Net) return Net + is + Wd : constant Width := Get_Width (D); + pragma Assert (Wd /= No_Width); + pragma Assert (Get_Width (Init) = Wd); + pragma Assert (Get_Width (Clk) = 1); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Idff); + O := Get_Output (Inst, 0); + Set_Width (O, Wd); + Connect (Get_Input (Inst, 0), Clk); + Connect (Get_Input (Inst, 1), D); + Connect (Get_Input (Inst, 2), Init); + return O; + end Build_Idff; + + function Build_Slice + (Ctxt : Context_Acc; I : Net; Off, W : Width) return Net + is + Wd : constant Width := Get_Width (I); + pragma Assert (Wd /= No_Width); + pragma Assert (W > 0); + pragma Assert (W + Off <= Wd); + Inst : Instance; + O : Net; + begin + Inst := New_Internal_Instance (Ctxt, Ctxt.M_Extract); + O := Get_Output (Inst, 0); + Set_Width (O, W); + Connect (Get_Input (Inst, 0), I); + Set_Param_Uns32 (Inst, 0, Off); + return O; + end Build_Slice; + + function Build_Extract_Bit + (Ctxt : Context_Acc; I : Net; Off : Width) return Net is + begin + return Build_Slice (Ctxt, I, Off, 1); + end Build_Extract_Bit; + +end Netlists.Builders; diff --git a/src/synth/netlists-builders.ads b/src/synth/netlists-builders.ads new file mode 100644 index 000000000..44f5d1a5e --- /dev/null +++ b/src/synth/netlists-builders.ads @@ -0,0 +1,120 @@ +-- API to build a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Gates; use Netlists.Gates; + +package Netlists.Builders is + type Context is private; + type Context_Acc is access Context; + + -- Create a builder for Design. Must be called once. + function Build_Builders (Design : Module) return Context_Acc; + + -- Set the parent for the new instances. + procedure Set_Parent (Ctxt : Context_Acc; Parent : Module); + + function Build_Dyadic (Ctxt : Context_Acc; + Id : Dyadic_Module_Id; + L, R : Net) return Net; + + function Build_Monadic (Ctxt : Context_Acc; + Id : Monadic_Module_Id; + Op : Net) return Net; + + function Build_Compare (Ctxt : Context_Acc; + Id : Compare_Module_Id; + L, R : Net) return Net; + + function Build_Const_UB32 (Ctxt : Context_Acc; + Val : Uns32; + W : Width) return Net; + function Build_Const_UL32 (Ctxt : Context_Acc; + Val : Uns32; + Xz : Uns32; + W : Width) return Net; + + function Build_Edge (Ctxt : Context_Acc; + Is_Pos : Boolean; + Src : Net) return Net; + + function Build_Mux2 (Ctxt : Context_Acc; + Sel : Net; + I0, I1 : Net) return Net; + function Build_Mux4 (Ctxt : Context_Acc; + Sel : Net; + I0, I1, I2, I3 : Net) return Net; + + function Build_Concat2 (Ctxt : Context_Acc; I0, I1 : Net) return Net; + function Build_Concat3 (Ctxt : Context_Acc; I0, I1, I2 : Net) return Net; + function Build_Concat4 (Ctxt : Context_Acc; I0, I1, I2, I3 : Net) + return Net; + + function Build_Trunc + (Ctxt : Context_Acc; Id : Module_Id; I : Net; W : Width) return Net; + function Build_Extend + (Ctxt : Context_Acc; Id : Module_Id; I : Net; W : Width) return Net; + + function Build_Slice + (Ctxt : Context_Acc; I : Net; Off, W : Width) return Net; + function Build_Extract_Bit + (Ctxt : Context_Acc; I : Net; Off : Width) return Net; + + function Build_Output (Ctxt : Context_Acc; W : Width) return Net; + function Build_Signal (Ctxt : Context_Acc; Name : Sname; W : Width) + return Net; + function Build_Isignal (Ctxt : Context_Acc; Name : Sname; Init : Net) + return Net; + + -- A simple flip-flop. + function Build_Dff (Ctxt : Context_Acc; + Clk : Net; + D : Net) return Net; + -- A flip-flop with an initial value (only for fpga) + function Build_Idff (Ctxt : Context_Acc; + Clk : Net; + D : Net; + Init : Net) return Net; +private + type Module_Arr is array (Module_Id range <>) of Module; + + type Context is record + Design : Module; + Parent : Module; + Num : Uns32; + M_Dyadic : Module_Arr (Dyadic_Module_Id); + M_Monadic : Module_Arr (Monadic_Module_Id); + M_Compare : Module_Arr (Compare_Module_Id); + M_Concat : Module_Arr (Concat_Module_Id); + M_Const_UB32 : Module; + M_Const_UL32 : Module; + M_Posedge : Module; + M_Negedge : Module; + M_Mux2 : Module; + M_Mux4 : Module; + M_Output : Module; + M_Signal : Module; + M_Isignal : Module; + M_Dff : Module; + M_Idff : Module; + M_Truncate : Module_Arr (Truncate_Module_Id); + M_Extend : Module_Arr (Extend_Module_Id); + M_Extract : Module; + end record; +end Netlists.Builders; diff --git a/src/synth/netlists-dump.adb b/src/synth/netlists-dump.adb new file mode 100644 index 000000000..7db8f850e --- /dev/null +++ b/src/synth/netlists-dump.adb @@ -0,0 +1,489 @@ +-- Routine to dump (for debugging purpose) a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Text_IO; use Ada.Text_IO; +with Name_Table; +with Netlists.Utils; use Netlists.Utils; +with Netlists.Iterators; use Netlists.Iterators; +with Netlists.Gates; use Netlists.Gates; + +package body Netlists.Dump is + procedure Put_Indent (Indent : Natural) is + begin + Put (String'(1 .. Indent * 2 => ' ')); + end Put_Indent; + + -- Like Put, but without the leading space (if any). + procedure Put_Trim (S : String) is + begin + if S'First <= S'Last and then S (S'First) = ' ' then + Put (S (S'First + 1 .. S'Last)); + else + Put (S); + end if; + end Put_Trim; + + procedure Dump_Name (N : Sname) + is + use Name_Table; + Prefix : Sname; + begin + -- Do not crash on No_Name. + if N = No_Sname then + Put ("*nil*"); + return; + end if; + + Prefix := Get_Sname_Prefix (N); + + case Get_Sname_Kind (N) is + when Sname_User => + if Prefix = No_Sname then + Put ("\"); + else + Dump_Name (Prefix); + Put ("."); + end if; + Put (Image (Get_Sname_Suffix (N))); + when Sname_Artificial => + if Prefix = No_Sname then + Put ("$"); + else + Dump_Name (Prefix); + Put ("."); + end if; + Put (Image (Get_Sname_Suffix (N))); + when Sname_Version => + Dump_Name (Prefix); + Put ("%"); + Put_Trim (Uns32'Image (Get_Sname_Version (N))); + end case; + end Dump_Name; + + procedure Dump_Input_Name (I : Input; With_Id : Boolean := False) + is + Inst : constant Instance := Get_Parent (I); + Idx : constant Port_Idx := Get_Port_Idx (I); + begin + Dump_Name (Get_Name (Inst)); + Put ('.'); + if Is_Self_Instance (Inst) then + Dump_Name (Get_Output_Desc (Get_Module (Inst), Idx).Name); + else + Dump_Name (Get_Input_Desc (Get_Module (Inst), Idx).Name); + end if; + if With_Id then + Put ('('); + Put_Trim (Input'Image (I)); + Put (')'); + end if; + end Dump_Input_Name; + + procedure Dump_Net_Name (N : Net; With_Id : Boolean := False) + is + Inst : constant Instance := Get_Parent (N); + Idx : constant Port_Idx := Get_Port_Idx (N); + begin + Dump_Name (Get_Name (Inst)); + Put ('.'); + if Is_Self_Instance (Inst) then + Dump_Name (Get_Input_Desc (Get_Module (Inst), Idx).Name); + else + Dump_Name (Get_Output_Desc (Get_Module (Inst), Idx).Name); + end if; + if With_Id then + Put ('('); + Put_Trim (Net'Image (N)); + Put (')'); + end if; + end Dump_Net_Name; + + procedure Dump_Parameter (Inst : Instance; Idx : Param_Idx) + is + Desc : constant Param_Desc := Get_Param_Desc (Inst, Idx); + begin + Dump_Name (Desc.Name); + Put ('='); + case Desc.Typ is + when Param_Invalid => + Put ("invalid"); + when Param_Uns32 => + Put_Trim (Uns32'Image (Get_Param_Uns32 (Inst, Idx))); + end case; + end Dump_Parameter; + + procedure Dump_Instance (Inst : Instance; Indent : Natural := 0) is + begin + Put_Indent (Indent); + Put ("instance "); + Dump_Name (Get_Name (Inst)); + Put (" ("); + Put_Trim (Instance'Image (Inst)); + Put (')'); + Put (": "); + Dump_Name (Get_Name (Get_Module (Inst))); + New_Line; + + if Get_Nbr_Params (Inst) > 0 then + Put_Indent (Indent + 1); + Put ("parameters"); + for P in Params (Inst) loop + pragma Warnings (Off, P); + Put (' '); + Dump_Parameter (Inst, Get_Param_Idx (P)); + end loop; + New_Line; + end if; + + if Get_Nbr_Inputs (Inst) > 0 then + Put_Indent (Indent + 1); + Put ("inputs"); + for I of Inputs (Inst) loop + Put (' '); + Dump_Input_Name (I, True); + end loop; + New_Line; + end if; + + if Get_Nbr_Outputs (Inst) > 0 then + Put_Indent (Indent + 1); + Put ("outputs"); + for I of Outputs (Inst) loop + Put (' '); + Dump_Net_Name (I, True); + end loop; + New_Line; + end if; + end Dump_Instance; + + procedure Disp_Width (W : Width) is + begin + if W /= 1 then + Put ('['); + if W = 0 then + Put ('?'); + else + Put_Trim (Width'Image (W - 1)); + Put (":0"); + end if; + Put (']'); + end if; + end Disp_Width; + + procedure Dump_Module_Header (M : Module; Indent : Natural := 0) is + begin + Put_Indent (Indent); + Put ("module ("); + Put_Trim (Module'Image (M)); + Put (") "); + Dump_Name (Get_Name (M)); + New_Line; + + for P of Params_Desc (M) loop + Put_Indent (Indent + 1); + Put ("parameter"); + Put (' '); + Dump_Name (P.Name); + Put (": "); + case P.Typ is + when Param_Invalid => + Put ("invalid"); + when Param_Uns32 => + Put ("uns32"); + end case; + New_Line; + end loop; + + for P of Ports_Desc (M) loop + Put_Indent (Indent + 1); + case P.Dir is + when Port_In => + Put ("input"); + when Port_Out => + Put ("output"); + when Port_Inout => + Put ("inout"); + end case; + Put (' '); + Dump_Name (P.Name); + Disp_Width (P.W); + Put (';'); + New_Line; + end loop; + end Dump_Module_Header; + + procedure Dump_Module (M : Module; Indent : Natural := 0) is + begin + Dump_Module_Header (M, Indent); + + for S of Sub_Modules (M) loop + Dump_Module (S, Indent + 1); + end loop; + + declare + Self : constant Instance := Get_Self_Instance (M); + begin + if Self /= No_Instance then + Dump_Instance (Self, Indent + 1); + end if; + end; + + for Inst of Instances (M) loop + Dump_Instance (Inst, Indent + 1); + end loop; + + for N of Nets (M) loop + Put_Indent (Indent + 1); + Put ("connect "); + Dump_Net_Name (N, True); + + declare + First : Boolean; + begin + First := True; + for S of Sinks (N) loop + if First then + Put (" -> "); + First := False; + else + Put (", "); + end if; + Dump_Input_Name (S, True); + end loop; + end; + New_Line; + end loop; + end Dump_Module; + + procedure Disp_Net_Name (N : Net) is + begin + if N = No_Net then + Put ("?"); + else + declare + Inst : constant Instance := Get_Parent (N); + Idx : constant Port_Idx := Get_Port_Idx (N); + begin + if Is_Self_Instance (Inst) then + Dump_Name (Get_Input_Desc (Get_Module (Inst), Idx).Name); + else + Dump_Name (Get_Name (Inst)); + Put ('.'); + Dump_Name (Get_Output_Desc (Get_Module (Inst), Idx).Name); + end if; + end; + end if; + end Disp_Net_Name; + + procedure Dump_Net_Name_And_Width (N : Net) is + begin + if N = No_Net then + Put ("?"); + else + Disp_Net_Name (N); + Disp_Width (Get_Width (N)); + end if; + end Dump_Net_Name_And_Width; + + Flag_Disp_Inline : constant Boolean := True; + + function Can_Inline (Inst : Instance) return Boolean is + begin + case Get_Id (Inst) is + when Id_Signal + | Id_Output => + return False; + when others => + return not Is_Self_Instance (Inst) + and then Get_Nbr_Outputs (Inst) = 1 + and then Has_One_Connection (Get_Output (Inst, 0)); + end case; + end Can_Inline; + + procedure Disp_Driver (Drv : Net) + is + Drv_Inst : Instance; + begin + if Drv = No_Net then + Put ('?'); + else + Drv_Inst := Get_Parent (Drv); + if Flag_Disp_Inline and then Can_Inline (Drv_Inst) then + Disp_Instance (Drv_Inst, False); + else + Disp_Net_Name (Drv); + end if; + end if; + end Disp_Driver; + + -- Debug routine: disp net driver + procedure Debug_Net (N : Net) is + begin + if N = No_Net then + Put ('?'); + else + Disp_Instance (Get_Parent (N), False); + end if; + New_Line; + end Debug_Net; + + pragma Unreferenced (Debug_Net); + + procedure Disp_Instance (Inst : Instance; With_Name : Boolean) + is + M : constant Module := Get_Module (Inst); + begin + if True then + -- Pretty-print for some gates + case Get_Id (M) is + when Id_Const_UB32 => + declare + W : constant Width := Get_Width (Get_Output (Inst, 0)); + V : Uns32; + begin + Put_Trim (Width'Image (W)); + Put ("'ub"); + V := Get_Param_Uns32 (Inst, 0); + for I in reverse 0 .. W - 1 loop + if (Shift_Right (V, Natural (I)) and 1) = 0 then + Put ('0'); + else + Put ('1'); + end if; + end loop; + end; + return; + + when Id_Extract => + Disp_Driver (Get_Driver (Get_Input (Inst, 0))); + Put ('['); + Put_Trim (Uns32'Image (Get_Param_Uns32 (Inst, 0))); + Put (']'); + return; + + when others => + null; + end case; + end if; + + Dump_Name (Get_Name (M)); + + if Get_Nbr_Params (M) > 0 then + declare + First : Boolean; + begin + First := True; + Put (" #("); + for P in Params (Inst) loop + pragma Warnings (Off, P); + if not First then + Put (", "); + end if; + First := False; + Dump_Parameter (Inst, Get_Param_Idx (P)); + end loop; + Put (")"); + end; + end if; + + if With_Name then + Put (' '); + Dump_Name (Get_Name (Inst)); + end if; + + if Get_Nbr_Inputs (M) > 0 then + declare + First : Boolean; + begin + First := True; + Put (" ("); + for I of Inputs (Inst) loop + if not First then + Put (", "); + end if; + First := False; + Disp_Driver (Get_Driver (I)); + end loop; + Put (')'); + end; + end if; + end Disp_Instance; + + procedure Disp_Instance_Assign (Inst : Instance; Indent : Natural := 0) is + begin + Put_Indent (Indent); + case Get_Nbr_Outputs (Inst) is + when 0 => + null; + when 1 => + Dump_Net_Name_And_Width (Get_Output (Inst, 0)); + Put (" := "); + when others => + declare + First : Boolean; + begin + First := True; + Put ('('); + for O of Outputs (Inst) loop + if not First then + Put (", "); + end if; + First := False; + Dump_Net_Name_And_Width (O); + end loop; + Put (") := "); + end; + end case; + + Disp_Instance (Inst, False); + New_Line; + end Disp_Instance_Assign; + + procedure Disp_Module (M : Module; Indent : Natural := 0) is + begin + Dump_Module_Header (M, Indent); + + for S of Sub_Modules (M) loop + if Get_Id (S) >= Id_User_None then + Disp_Module (S, Indent + 1); + end if; + end loop; + + for Inst of Instances (M) loop + if not (Flag_Disp_Inline and then Can_Inline (Inst)) then + Disp_Instance_Assign (Inst, Indent + 1); + end if; + end loop; + + declare + Self : constant Instance := Get_Self_Instance (M); + begin + if Self /= No_Instance then + for I of Inputs (Self) loop + Put_Indent (Indent + 1); + Dump_Name (Get_Output_Desc (M, Get_Port_Idx (I)).Name); + Put (" := "); + Disp_Net_Name (Get_Driver (I)); + New_Line; + end loop; + end if; + end; + end Disp_Module; +end Netlists.Dump; diff --git a/src/synth/netlists-dump.ads b/src/synth/netlists-dump.ads new file mode 100644 index 000000000..7cca85400 --- /dev/null +++ b/src/synth/netlists-dump.ads @@ -0,0 +1,31 @@ +-- Routine to dump (for debugging purpose) a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Netlists.Dump is + procedure Dump_Net_Name (N : Net; With_Id : Boolean := False); + procedure Disp_Driver (Drv : Net); + procedure Disp_Instance (Inst : Instance; With_Name : Boolean); + + -- Raw dump. + procedure Dump_Module (M : Module; Indent : Natural := 0); + + -- More humain readable output. + procedure Disp_Module (M : Module; Indent : Natural := 0); +end Netlists.Dump; diff --git a/src/synth/netlists-gates.ads b/src/synth/netlists-gates.ads new file mode 100644 index 000000000..1f03b0ce9 --- /dev/null +++ b/src/synth/netlists-gates.ads @@ -0,0 +1,114 @@ +-- Gates declaration +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Netlists.Gates is + -- Dyadic gates. Inputs and output have the same width. + Id_And : constant Module_Id := 3; + Id_Or : constant Module_Id := 4; + Id_Xor : constant Module_Id := 5; + Id_Nand : constant Module_Id := 6; + Id_Nor : constant Module_Id := 7; + Id_Xnor : constant Module_Id := 8; + + Id_Add : constant Module_Id := 9; + Id_Sub : constant Module_Id := 10; + Id_Mul : constant Module_Id := 11; + + subtype Dyadic_Module_Id is Module_Id range Id_And .. Id_Mul; + + Id_Buf : constant Module_Id := 13; + Id_Not : constant Module_Id := 14; + + Id_Neg : constant Module_Id := 15; + + subtype Monadic_Module_Id is Module_Id range Id_Buf .. Id_Neg; + + Id_Eq : constant Module_Id := 16; + Id_Ne : constant Module_Id := 17; + Id_Ule : constant Module_Id := 18; + Id_Sle : constant Module_Id := 19; + Id_Ult : constant Module_Id := 18; + Id_Slt : constant Module_Id := 19; + Id_Uge : constant Module_Id := 18; + Id_Sge : constant Module_Id := 19; + Id_Ugt : constant Module_Id := 18; + Id_Sgt : constant Module_Id := 19; + + subtype Compare_Module_Id is Module_Id range Id_Eq .. Id_Sgt; + + Id_Red_And : constant Module_Id := 20; + Id_Red_Or : constant Module_Id := 21; + + Id_Concat2 : constant Module_Id := 22; + Id_Concat3 : constant Module_Id := 23; + Id_Concat4 : constant Module_Id := 24; + + subtype Concat_Module_Id is Module_Id range Id_Concat2 .. Id_Concat4; + + Id_Split2 : constant Module_Id := 25; + Id_Split3 : constant Module_Id := 26; + + Id_Mux2 : constant Module_Id := 27; + Id_Mux4 : constant Module_Id := 28; + + -- Like a wire: the output is equal to the input, but could be elimited + -- at any time. Isignal has an initial value. + Id_Signal : constant Module_Id := 29; + Id_Isignal : constant Module_Id := 30; + Id_Output : constant Module_Id := 31; + + -- Note: initial values must be constant nets. + Id_Dff : constant Module_Id := 32; + Id_Adff : constant Module_Id := 33; -- Async reset + Id_Idff : constant Module_Id := 34; -- With initial value + Id_Iadff : constant Module_Id := 35; -- With initial value, async reset + + -- Width change: truncate or extend. Sign is know in order to possibly + -- detect loss of value. + Id_Utrunc : constant Module_Id := 40; + Id_Strunc : constant Module_Id := 41; + Id_Uextend : constant Module_Id := 42; + Id_Sextend : constant Module_Id := 43; + + subtype Truncate_Module_Id is Module_Id range Id_Utrunc .. Id_Strunc; + subtype Extend_Module_Id is Module_Id range Id_Uextend .. Id_Sextend; + + -- Extract a bit or a slice at a constant offset. + Id_Extract : constant Module_Id := 44; + + -- Edge detectors. These are pseudo gates. + Id_Posedge : constant Module_Id := 50; + Id_Negedge : constant Module_Id := 51; + + subtype Edge_Module_Id is Module_Id range Id_Posedge .. Id_Negedge; + + -- Constants are gates with only one constant output. There are multiple + -- kind of constant gates: for small width, the value is stored as a + -- parameter, possibly signed or unsigned extended. For large width + -- (> 128), the value is stored in a table. + Id_Const_UB32 : constant Module_Id := 56; + Id_Const_SB32 : constant Module_Id := 57; + Id_Const_UB64 : constant Module_Id := 58; + Id_Const_SB64 : constant Module_Id := 59; + Id_Const_UB128 : constant Module_Id := 60; + Id_Const_SB128 : constant Module_Id := 61; + Id_Const_UL32 : constant Module_Id := 62; + Id_Const_SL32 : constant Module_Id := 63; +end Netlists.Gates; diff --git a/src/synth/netlists-gates_ports.adb b/src/synth/netlists-gates_ports.adb new file mode 100644 index 000000000..06990a29f --- /dev/null +++ b/src/synth/netlists-gates_ports.adb @@ -0,0 +1,45 @@ +-- Easy access to ports (of some gates). +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Gates; use Netlists.Gates; +with Netlists.Utils; use Netlists.Utils; + +package body Netlists.Gates_Ports is + function Get_Mux2_Sel (Inst : Instance) return Input + is + pragma Assert (Get_Id (Inst) = Id_Mux2); + begin + return Get_Input (Inst, 0); + end Get_Mux2_Sel; + + function Get_Mux2_I0 (Inst : Instance) return Input + is + pragma Assert (Get_Id (Inst) = Id_Mux2); + begin + return Get_Input (Inst, 1); + end Get_Mux2_I0; + + function Get_Mux2_I1 (Inst : Instance) return Input + is + pragma Assert (Get_Id (Inst) = Id_Mux2); + begin + return Get_Input (Inst, 2); + end Get_Mux2_I1; +end Netlists.Gates_Ports; diff --git a/src/synth/netlists-gates_ports.ads b/src/synth/netlists-gates_ports.ads new file mode 100644 index 000000000..f1b396dd5 --- /dev/null +++ b/src/synth/netlists-gates_ports.ads @@ -0,0 +1,25 @@ +-- Easy access to ports (of some gates). +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Netlists.Gates_Ports is + function Get_Mux2_Sel (Inst : Instance) return Input; + function Get_Mux2_I0 (Inst : Instance) return Input; + function Get_Mux2_I1 (Inst : Instance) return Input; +end Netlists.Gates_Ports; diff --git a/src/synth/netlists-iterators.adb b/src/synth/netlists-iterators.adb new file mode 100644 index 000000000..babf74eb8 --- /dev/null +++ b/src/synth/netlists-iterators.adb @@ -0,0 +1,387 @@ +-- Iterators for elements of a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Utils; use Netlists.Utils; + +package body Netlists.Iterators is + function Sub_Modules (M : Module) return Modules_Iterator + is + pragma Assert (Is_Valid (M)); + begin + return Modules_Iterator'(M => M); + end Sub_Modules; + + function Modules_First (It : Modules_Iterator) return Modules_Cursor is + begin + return Modules_Cursor'(M => Get_First_Sub_Module (It.M)); + end Modules_First; + + function Modules_Next (It : Modules_Iterator; Cur : Modules_Cursor) + return Modules_Cursor + is + pragma Unreferenced (It); + begin + return Modules_Cursor'(M => Get_Next_Sub_Module (Cur.M)); + end Modules_Next; + + function Modules_Has_Element (It : Modules_Iterator; Cur : Modules_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.M /= No_Module; + end Modules_Has_Element; + + function Modules_Element (It : Modules_Iterator; Cur : Modules_Cursor) + return Module + is + pragma Unreferenced (It); + begin + return Cur.M; + end Modules_Element; + + function Ports_Desc_First (It : Ports_Desc_Iterator) + return Ports_Desc_Cursor is + begin + return Ports_Desc_Cursor' + (Idx => Get_First_Port_Desc (It.M), + Num => Get_Nbr_Inputs (It.M) + Get_Nbr_Outputs (It.M)); + end Ports_Desc_First; + + function Ports_Desc_Next (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) + return Ports_Desc_Cursor + is + pragma Unreferenced (It); + begin + return Ports_Desc_Cursor'(Idx => Cur.Idx + 1, + Num => Cur.Num - 1); + end Ports_Desc_Next; + + function Ports_Desc_Has_Element + (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Num > 0; + end Ports_Desc_Has_Element; + + function Ports_Desc_Element + (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) return Port_Desc + is + pragma Unreferenced (It); + begin + return Get_Port_Desc (Cur.Idx); + end Ports_Desc_Element; + + function Ports_Desc (M : Module) return Ports_Desc_Iterator + is + pragma Assert (Is_Valid (M)); + begin + return Ports_Desc_Iterator'(M => M); + end Ports_Desc; + + function Params_Desc_First (It : Params_Desc_Iterator) + return Params_Desc_Cursor is + begin + return Params_Desc_Cursor' + (Idx => 0, + Num => Get_Nbr_Params (It.M)); + end Params_Desc_First; + + function Params_Desc_Next + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) + return Params_Desc_Cursor + is + pragma Unreferenced (It); + begin + return Params_Desc_Cursor'(Idx => Cur.Idx + 1, + Num => Cur.Num - 1); + end Params_Desc_Next; + + function Params_Desc_Has_Element + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Num > 0; + end Params_Desc_Has_Element; + + function Params_Desc_Element + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) return Param_Desc is + begin + return Get_Param_Desc (It.M, Cur.Idx); + end Params_Desc_Element; + + function Params_Desc (M : Module) return Params_Desc_Iterator is + begin + return Params_Desc_Iterator'(M => M); + end Params_Desc; + + function Instances_First (It : Instances_Iterator) + return Instances_Cursor is + begin + return Instances_Cursor'(Inst => Get_First_Instance (It.M)); + end Instances_First; + + function Instances_Next (It : Instances_Iterator; Cur : Instances_Cursor) + return Instances_Cursor + is + pragma Unreferenced (It); + begin + return Instances_Cursor'(Inst => Get_Next_Instance (Cur.Inst)); + end Instances_Next; + + function Instances_Has_Element + (It : Instances_Iterator; Cur : Instances_Cursor) return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Inst /= No_Instance; + end Instances_Has_Element; + + function Instances_Element + (It : Instances_Iterator; Cur : Instances_Cursor) return Instance + is + pragma Unreferenced (It); + begin + return Cur.Inst; + end Instances_Element; + + function Instances (M : Module) return Instances_Iterator is + begin + return Instances_Iterator'(M => M); + end Instances; + + function Inputs_First (It : Inputs_Iterator) return Inputs_Cursor is + begin + return Inputs_Cursor'(Idx => 0, + Nbr => Get_Nbr_Inputs (It.Inst)); + end Inputs_First; + + function Inputs_Next (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Inputs_Cursor + is + pragma Unreferenced (It); + begin + return Inputs_Cursor'(Idx => Cur.Idx + 1, + Nbr => Cur.Nbr); + end Inputs_Next; + + function Inputs_Has_Element (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Idx < Cur.Nbr; + end Inputs_Has_Element; + + function Inputs_Element (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Input is + begin + return Get_Input (It.Inst, Cur.Idx); + end Inputs_Element; + + function Inputs (Inst : Instance) return Inputs_Iterator is + begin + return Inputs_Iterator'(Inst => Inst); + end Inputs; + + function Outputs_First (It : Outputs_Iterator) return Outputs_Cursor is + begin + return Outputs_Cursor'(Idx => 0, + Nbr => Get_Nbr_Outputs (It.Inst)); + end Outputs_First; + + function Outputs_Next (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Outputs_Cursor + is + pragma Unreferenced (It); + begin + return Outputs_Cursor'(Idx => Cur.Idx + 1, + Nbr => Cur.Nbr); + end Outputs_Next; + + function Outputs_Has_Element (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Idx < Cur.Nbr; + end Outputs_Has_Element; + + function Outputs_Element (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Net is + begin + return Get_Output (It.Inst, Cur.Idx); + end Outputs_Element; + + function Outputs (Inst : Instance) return Outputs_Iterator is + begin + return Outputs_Iterator'(Inst => Inst); + end Outputs; + + function Params_First (It : Params_Iterator) return Params_Cursor is + begin + return Params_Cursor'(Idx => 0, + Nbr => Get_Nbr_Params (It.Inst)); + end Params_First; + + function Params_Next (It : Params_Iterator; Cur : Params_Cursor) + return Params_Cursor + is + pragma Unreferenced (It); + begin + return Params_Cursor'(Idx => Cur.Idx + 1, + Nbr => Cur.Nbr - 1); + end Params_Next; + + function Params_Has_Element (It : Params_Iterator; Cur : Params_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Nbr > 0; + end Params_Has_Element; + + function Params (Inst : Instance) return Params_Iterator is + begin + return Params_Iterator'(Inst => Inst); + end Params; + + function Get_Param_Idx (Cur : Params_Cursor) return Param_Idx is + begin + return Cur.Idx; + end Get_Param_Idx; + + function Nets_First (It : Nets_Iterator) return Nets_Cursor + is + Inst : Instance; + Num : Port_Nbr; + begin + Inst := Get_Self_Instance (It.M); + loop + if Inst = No_Instance then + -- No instance. + return Nets_Cursor'(Inst => No_Instance, + N => No_Net, + Num => 0); + end if; + Num := Get_Nbr_Outputs (Inst); + if Num = 0 then + -- No output for this instance. + Inst := Get_Next_Instance (Inst); + else + return Nets_Cursor'(Inst => Inst, + N => Get_First_Output (Inst), + Num => Num); + end if; + end loop; + end Nets_First; + + function Nets_Next (It : Nets_Iterator; Cur : Nets_Cursor) + return Nets_Cursor + is + pragma Unreferenced (It); + begin + if Cur.Num > 1 then + return Nets_Cursor'(Inst => Cur.Inst, + N => Cur.N + 1, + Num => Cur.Num - 1); + else + declare + Inst : Instance; + Num : Port_Nbr; + begin + Inst := Cur.Inst; + loop + Inst := Get_Next_Instance (Inst); + exit when Inst = No_Instance; + Num := Get_Nbr_Outputs (Inst); + pragma Assert (Num > 0); + return Nets_Cursor'(Inst => Inst, + N => Get_First_Output (Inst), + Num => Num); + end loop; + end; + return Nets_Cursor'(Inst => No_Instance, + N => No_Net, + Num => 0); + end if; + end Nets_Next; + + function Nets_Has_Element (It : Nets_Iterator; Cur : Nets_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.Num > 0 or Cur.Inst /= No_Instance; + end Nets_Has_Element; + + function Nets_Element (It : Nets_Iterator; Cur : Nets_Cursor) + return Net + is + pragma Unreferenced (It); + begin + return Cur.N; + end Nets_Element; + + function Nets (M : Module) return Nets_Iterator + is + pragma Assert (Is_Valid (M)); + begin + return Nets_Iterator'(M => M); + end Nets; + + function Sinks_First (It : Sinks_Iterator) return Sinks_Cursor is + begin + return Sinks_Cursor'(S => Get_First_Sink (It.N)); + end Sinks_First; + + function Sinks_Next (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Sinks_Cursor + is + pragma Unreferenced (It); + begin + return Sinks_Cursor'(S => Get_Next_Sink (Cur.S)); + end Sinks_Next; + + function Sinks_Has_Element (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Boolean + is + pragma Unreferenced (It); + begin + return Cur.S /= No_Input; + end Sinks_Has_Element; + + function Sinks_Element (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Input + is + pragma Unreferenced (It); + begin + return Cur.S; + end Sinks_Element; + + function Sinks (N : Net) return Sinks_Iterator is + begin + pragma Assert (Is_Valid (N)); + return Sinks_Iterator'(N => N); + end Sinks; + +end Netlists.Iterators; diff --git a/src/synth/netlists-iterators.ads b/src/synth/netlists-iterators.ads new file mode 100644 index 000000000..9a88ab9cf --- /dev/null +++ b/src/synth/netlists-iterators.ads @@ -0,0 +1,261 @@ +-- Iterators for elements of a netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Netlists.Iterators is + -- Iterators. + + -- Iterate over sub-modules. + type Modules_Cursor is private; + type Modules_Iterator is private with + Iterable => (First => Modules_First, + Next => Modules_Next, + Has_Element => Modules_Has_Element, + Element => Modules_Element); + function Sub_Modules (M : Module) return Modules_Iterator; + + -- Iterate over ports desc of a module. + type Ports_Desc_Cursor is private; + type Ports_Desc_Iterator is private with + Iterable => (First => Ports_Desc_First, + Next => Ports_Desc_Next, + Has_Element => Ports_Desc_Has_Element, + Element => Ports_Desc_Element); + function Ports_Desc (M : Module) return Ports_Desc_Iterator; + + -- Iterate over param desc of a module + type Params_Desc_Cursor is private; + type Params_Desc_Iterator is private with + Iterable => (First => Params_Desc_First, + Next => Params_Desc_Next, + Has_Element => Params_Desc_Has_Element, + Element => Params_Desc_Element); + function Params_Desc (M : Module) return Params_Desc_Iterator; + + -- Iterate over instances in a module, excluding the self-instance. + type Instances_Cursor is private; + type Instances_Iterator is private with + Iterable => (First => Instances_First, + Next => Instances_Next, + Has_Element => Instances_Has_Element, + Element => Instances_Element); + function Instances (M : Module) return Instances_Iterator; + + -- Iterate over inputs of an instance. + type Inputs_Cursor is private; + type Inputs_Iterator is private with + Iterable => (First => Inputs_First, + Next => Inputs_Next, + Has_Element => Inputs_Has_Element, + Element => Inputs_Element); + function Inputs (Inst : Instance) return Inputs_Iterator; + + -- Iterate over outputs of an instance. + type Outputs_Cursor is private; + type Outputs_Iterator is private with + Iterable => (First => Outputs_First, + Next => Outputs_Next, + Has_Element => Outputs_Has_Element, + Element => Outputs_Element); + function Outputs (Inst : Instance) return Outputs_Iterator; + + -- Iterate over parameters of an instance. + type Params_Cursor is private; + type Params_Iterator is private with + Iterable => (First => Params_First, + Next => Params_Next, + Has_Element => Params_Has_Element); + function Params (Inst : Instance) return Params_Iterator; + function Get_Param_Idx (Cur : Params_Cursor) return Param_Idx; + + -- Iterate over nets of a module. + type Nets_Cursor is private; + type Nets_Iterator is private with + Iterable => (First => Nets_First, + Next => Nets_Next, + Has_Element => Nets_Has_Element, + Element => Nets_Element); + function Nets (M : Module) return Nets_Iterator; + + -- Iterate over sinks of a net. + type Sinks_Cursor is private; + type Sinks_Iterator is private with + Iterable => (First => Sinks_First, + Next => Sinks_Next, + Has_Element => Sinks_Has_Element, + Element => Sinks_Element); + function Sinks (N : Net) return Sinks_Iterator; + +private + type Modules_Cursor is record + M : Module; + end record; + + type Modules_Iterator is record + M : Module; + end record; + + function Modules_First (It : Modules_Iterator) return Modules_Cursor + with Inline; + function Modules_Next (It : Modules_Iterator; Cur : Modules_Cursor) + return Modules_Cursor + with Inline; + function Modules_Has_Element (It : Modules_Iterator; Cur : Modules_Cursor) + return Boolean + with Inline; + function Modules_Element (It : Modules_Iterator; Cur : Modules_Cursor) + return Module + with Inline; + + type Ports_Desc_Iterator is record + M : Module; + end record; + + type Ports_Desc_Cursor is record + Idx : Port_Desc_Idx; + Num : Port_Nbr; + end record; + + function Ports_Desc_First (It : Ports_Desc_Iterator) + return Ports_Desc_Cursor; + function Ports_Desc_Next (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) + return Ports_Desc_Cursor; + function Ports_Desc_Has_Element + (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) return Boolean; + function Ports_Desc_Element + (It : Ports_Desc_Iterator; Cur : Ports_Desc_Cursor) return Port_Desc; + + type Params_Desc_Iterator is record + M : Module; + end record; + + type Params_Desc_Cursor is record + Idx : Param_Idx; + Num : Param_Nbr; + end record; + + function Params_Desc_First (It : Params_Desc_Iterator) + return Params_Desc_Cursor; + function Params_Desc_Next + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) + return Params_Desc_Cursor; + function Params_Desc_Has_Element + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) return Boolean; + function Params_Desc_Element + (It : Params_Desc_Iterator; Cur : Params_Desc_Cursor) return Param_Desc; + + type Instances_Iterator is record + M : Module; + end record; + + type Instances_Cursor is record + Inst : Instance; + end record; + + function Instances_First (It : Instances_Iterator) return Instances_Cursor; + function Instances_Next (It : Instances_Iterator; Cur : Instances_Cursor) + return Instances_Cursor; + function Instances_Has_Element + (It : Instances_Iterator; Cur : Instances_Cursor) return Boolean; + function Instances_Element + (It : Instances_Iterator; Cur : Instances_Cursor) return Instance; + + type Inputs_Cursor is record + Idx : Port_Idx; + Nbr : Port_Nbr; + end record; + + type Inputs_Iterator is record + Inst : Instance; + end record; + + function Inputs_First (It : Inputs_Iterator) return Inputs_Cursor; + function Inputs_Next (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Inputs_Cursor; + function Inputs_Has_Element (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Boolean; + function Inputs_Element (It : Inputs_Iterator; Cur : Inputs_Cursor) + return Input; + + type Outputs_Cursor is record + Idx : Port_Idx; + Nbr : Port_Nbr; + end record; + + type Outputs_Iterator is record + Inst : Instance; + end record; + + function Outputs_First (It : Outputs_Iterator) return Outputs_Cursor; + function Outputs_Next (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Outputs_Cursor; + function Outputs_Has_Element (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Boolean; + function Outputs_Element (It : Outputs_Iterator; Cur : Outputs_Cursor) + return Net; + + type Params_Cursor is record + Idx : Param_Idx; + Nbr : Param_Nbr; + end record; + + type Params_Iterator is record + Inst : Instance; + end record; + + function Params_First (It : Params_Iterator) return Params_Cursor; + function Params_Next (It : Params_Iterator; Cur : Params_Cursor) + return Params_Cursor; + function Params_Has_Element (It : Params_Iterator; Cur : Params_Cursor) + return Boolean; + + type Nets_Cursor is record + Inst : Instance; + N : Net; + Num : Port_Nbr; + end record; + + type Nets_Iterator is record + M : Module; + end record; + + function Nets_First (It : Nets_Iterator) return Nets_Cursor; + function Nets_Next (It : Nets_Iterator; Cur : Nets_Cursor) + return Nets_Cursor; + function Nets_Has_Element (It : Nets_Iterator; Cur : Nets_Cursor) + return Boolean; + function Nets_Element (It : Nets_Iterator; Cur : Nets_Cursor) + return Net; + + type Sinks_Cursor is record + S : Input; + end record; + + type Sinks_Iterator is record + N : Net; + end record; + + function Sinks_First (It : Sinks_Iterator) return Sinks_Cursor; + function Sinks_Next (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Sinks_Cursor; + function Sinks_Has_Element (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Boolean; + function Sinks_Element (It : Sinks_Iterator; Cur : Sinks_Cursor) + return Input; +end Netlists.Iterators; diff --git a/src/synth/netlists-utils.adb b/src/synth/netlists-utils.adb new file mode 100644 index 000000000..3dece320b --- /dev/null +++ b/src/synth/netlists-utils.adb @@ -0,0 +1,126 @@ +-- Netlist utilities (composed of a few calls). +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package body Netlists.Utils is + function Get_Nbr_Inputs (Inst : Instance) return Port_Nbr + is + M : constant Module := Get_Module (Inst); + begin + if Is_Self_Instance (Inst) then + return Get_Nbr_Outputs (M); + else + return Get_Nbr_Inputs (M); + end if; + end Get_Nbr_Inputs; + + function Get_Nbr_Outputs (Inst : Instance) return Port_Nbr + is + M : constant Module := Get_Module (Inst); + begin + if Is_Self_Instance (Inst) then + return Get_Nbr_Inputs (M); + else + return Get_Nbr_Outputs (M); + end if; + end Get_Nbr_Outputs; + + function Get_Nbr_Params (Inst : Instance) return Param_Nbr + is + M : constant Module := Get_Module (Inst); + begin + return Get_Nbr_Params (M); + end Get_Nbr_Params; + + function Get_Param_Desc + (Inst : Instance; Param : Param_Idx) return Param_Desc is + begin + return Get_Param_Desc (Get_Module (Inst), Param); + end Get_Param_Desc; + + function Get_Id (Inst : Instance) return Module_Id is + begin + return Get_Id (Get_Module (Inst)); + end Get_Id; + + function Get_Input_Name (M : Module; I : Port_Idx) return Sname is + begin + return Get_Input_Desc (M, I).Name; + end Get_Input_Name; + + function Get_Output_Name (M : Module; I : Port_Idx) return Sname is + begin + return Get_Output_Desc (M, I).Name; + end Get_Output_Name; + + function Is_Connected (O : Net) return Boolean is + begin + return Get_First_Sink (O) /= No_Input; + end Is_Connected; + + function Has_One_Connection (O : Net) return Boolean + is + Inp : Input; + begin + Inp := Get_First_Sink (O); + if Inp = No_Input then + -- No connection. + return False; + end if; + Inp := Get_Next_Sink (Inp); + return Inp = No_Input; + end Has_One_Connection; + + procedure Disconnect_And_Free (I : Input) + is + I_Net : constant Net := Get_Driver (I); + Inst : constant Instance := Get_Net_Parent (I_Net); + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + begin + -- First disconnect. + Disconnect (I); + + -- Quick check: is output (of I) still used ? + if Is_Connected (I_Net) then + return; + end if; + + -- Check that all outputs are unused. + Nbr_Outputs := Get_Nbr_Outputs (Inst); + if Nbr_Outputs > 1 then + for K in 0 .. Nbr_Outputs - 1 loop + if Is_Connected (Get_Output (Inst, K)) then + return; + end if; + end loop; + end if; + + -- First disconnect inputs. + Nbr_Inputs := Get_Nbr_Inputs (Inst); + if Nbr_Inputs > 0 then + for K in 0 .. Nbr_Inputs - 1 loop + Disconnect_And_Free (Get_Input (Inst, K)); + end loop; + end if; + + -- Free Inst + Free_Instance (Inst); + end Disconnect_And_Free; +end Netlists.Utils; diff --git a/src/synth/netlists-utils.ads b/src/synth/netlists-utils.ads new file mode 100644 index 000000000..60b8b7a7a --- /dev/null +++ b/src/synth/netlists-utils.ads @@ -0,0 +1,44 @@ +-- Netlist utilities (composed of a few calls). +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Netlists.Utils is + function Get_Nbr_Inputs (Inst : Instance) return Port_Nbr; + function Get_Nbr_Outputs (Inst : Instance) return Port_Nbr; + function Get_Nbr_Params (Inst : Instance) return Param_Nbr; + + function Get_Param_Desc + (Inst : Instance; Param : Param_Idx) return Param_Desc; + + function Get_Id (Inst : Instance) return Module_Id; + + function Get_Input_Name (M : Module; I : Port_Idx) return Sname; + function Get_Output_Name (M : Module; I : Port_Idx) return Sname; + + -- Return True iff O has at least one sink (ie is connected to at least one + -- input). + function Is_Connected (O : Net) return Boolean; + + -- Return True iff O has one sink (is connected to one input). + function Has_One_Connection (O : Net) return Boolean; + + -- Disconnect input I. If the driver of I has no output(s) connected, + -- disconnect and free it. + procedure Disconnect_And_Free (I : Input); +end Netlists.Utils; diff --git a/src/synth/netlists.adb b/src/synth/netlists.adb new file mode 100644 index 000000000..d8f286a8a --- /dev/null +++ b/src/synth/netlists.adb @@ -0,0 +1,812 @@ +-- Netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Utils; use Netlists.Utils; +with Tables; + +package body Netlists is + + -- Names + + package Snames_Table is new Tables + (Table_Component_Type => Sname_Record, + Table_Index_Type => Sname, + Table_Low_Bound => 0, + Table_Initial => 1024); + + function New_Sname_User (Id : Name_Id) return Sname is + begin + Snames_Table.Append ((Kind => Sname_User, + Prefix => No_Sname, + Suffix => Uns32 (Id))); + return Snames_Table.Last; + end New_Sname_User; + + function New_Sname_Artificial (Id : Name_Id) return Sname is + begin + Snames_Table.Append ((Kind => Sname_Artificial, + Prefix => No_Sname, + Suffix => Uns32 (Id))); + return Snames_Table.Last; + end New_Sname_Artificial; + + function New_Sname (Prefix : Sname; Suffix : Name_Id) return Sname is + begin + Snames_Table.Append ((Kind => Sname_User, + Prefix => Prefix, + Suffix => Uns32 (Suffix))); + return Snames_Table.Last; + end New_Sname; + + function New_Sname_Version (Prefix : Sname; Ver : Uns32) return Sname is + begin + Snames_Table.Append ((Kind => Sname_Version, + Prefix => Prefix, + Suffix => Ver)); + return Snames_Table.Last; + end New_Sname_Version; + + function Is_Valid (Name : Sname) return Boolean is + begin + return Name > No_Sname and Name <= Snames_Table.Last; + end Is_Valid; + + function Get_Sname_Kind (Name : Sname) return Sname_Kind is + begin + pragma Assert (Is_Valid (Name)); + return Snames_Table.Table (Name).Kind; + end Get_Sname_Kind; + + function Get_Sname_Prefix (Name : Sname) return Sname is + begin + pragma Assert (Is_Valid (Name)); + return Snames_Table.Table (Name).Prefix; + end Get_Sname_Prefix; + + function Get_Sname_Suffix (Name : Sname) return Name_Id + is + subtype Snames_Suffix is Sname_Kind range Sname_User .. Sname_Artificial; + begin + pragma Assert (Is_Valid (Name)); + pragma Assert (Get_Sname_Kind (Name) in Snames_Suffix); + return Name_Id (Snames_Table.Table (Name).Suffix); + end Get_Sname_Suffix; + + function Get_Sname_Version (Name : Sname) return Uns32 is + begin + pragma Assert (Is_Valid (Name)); + pragma Assert (Get_Sname_Kind (Name) = Sname_Version); + return Snames_Table.Table (Name).Suffix; + end Get_Sname_Version; + + function Get_Sname_Num (Name : Sname) return Uns32 is + begin + pragma Assert (Is_Valid (Name)); + pragma Assert (Get_Sname_Kind (Name) = Sname_Artificial); + return Snames_Table.Table (Name).Suffix; + end Get_Sname_Num; + + + -- Modules + + package Modules_Table is new Tables + (Table_Component_Type => Module_Record, + Table_Index_Type => Module, + Table_Low_Bound => No_Module, + Table_Initial => 1024); + + function New_Design (Name : Sname) return Module + is + Res : Module; + Self : Instance; + begin + Modules_Table.Append ((Parent => No_Module, + Name => Name, + Id => Id_Design, + First_Port_Desc => No_Port_Desc_Idx, + Nbr_Inputs => 0, + Nbr_Outputs => 0, + First_Param_Desc => No_Param_Desc_Idx, + Nbr_Params => 0, + First_Sub_Module => No_Module, + Last_Sub_Module => No_Module, + Next_Sub_Module => No_Module, + First_Instance => No_Instance, + Last_Instance => No_Instance)); + Res := Modules_Table.Last; + Self := Create_Self_Instance (Res); + pragma Unreferenced (Self); + + return Res; + end New_Design; + + function Is_Valid (M : Module) return Boolean is + begin + return M > No_Module and then M <= Modules_Table.Last; + end Is_Valid; + + function New_User_Module (Parent : Module; + Name : Sname; + Id : Module_Id; + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + Nbr_Params : Param_Nbr := 0) + return Module + is + pragma Assert (Is_Valid (Parent)); + pragma Assert (Nbr_Inputs + Nbr_Outputs > 0); + Parent_Rec : Module_Record renames Modules_Table.Table (Parent); + Res : Module; + begin + Modules_Table.Append + ((Parent => Parent, + Name => Name, + Id => Id, + First_Port_Desc => No_Port_Desc_Idx, + Nbr_Inputs => Nbr_Inputs, + Nbr_Outputs => Nbr_Outputs, + First_Param_Desc => No_Param_Desc_Idx, + Nbr_Params => Nbr_Params, + First_Sub_Module => No_Module, + Last_Sub_Module => No_Module, + Next_Sub_Module => No_Module, + First_Instance => No_Instance, + Last_Instance => No_Instance)); + Res := Modules_Table.Last; + + -- Append + if Parent_Rec.First_Sub_Module = No_Module then + Parent_Rec.First_Sub_Module := Res; + else + Modules_Table.Table (Parent_Rec.Last_Sub_Module).Next_Sub_Module := + Res; + end if; + Parent_Rec.Last_Sub_Module := Res; + + return Res; + end New_User_Module; + + function Get_Module_Name (M : Module) return Sname is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Name; + end Get_Module_Name; + + function Get_Id (M : Module) return Module_Id is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Id; + end Get_Id; + + function Get_Nbr_Inputs (M : Module) return Port_Nbr is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Nbr_Inputs; + end Get_Nbr_Inputs; + + function Get_Nbr_Outputs (M : Module) return Port_Nbr is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Nbr_Outputs; + end Get_Nbr_Outputs; + + function Get_Nbr_Params (M : Module) return Param_Nbr is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Nbr_Params; + end Get_Nbr_Params; + + function Get_First_Port_Desc (M : Module) return Port_Desc_Idx is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).First_Port_Desc; + end Get_First_Port_Desc; + + function Get_Input_First_Desc (M : Module) return Port_Desc_Idx + is + pragma Assert (Is_Valid (M)); + begin + return Modules_Table.Table (M).First_Port_Desc; + end Get_Input_First_Desc; + + function Get_Output_First_Desc (M : Module) return Port_Desc_Idx + is + pragma Assert (Is_Valid (M)); + begin + return Modules_Table.Table (M).First_Port_Desc + + Port_Desc_Idx (Modules_Table.Table (M).Nbr_Inputs); + end Get_Output_First_Desc; + + function Get_Self_Instance (M : Module) return Instance is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).First_Instance; + end Get_Self_Instance; + + function Get_First_Instance (M : Module) return Instance + is + First : constant Instance := Get_Self_Instance (M); + begin + if First = No_Instance then + -- Empty module. + return No_Instance; + else + return Get_Next_Instance (First); + end if; + end Get_First_Instance; + + function Get_First_Sub_Module (M : Module) return Module is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).First_Sub_Module; + end Get_First_Sub_Module; + + function Get_Next_Sub_Module (M : Module) return Module is + begin + pragma Assert (Is_Valid (M)); + return Modules_Table.Table (M).Next_Sub_Module; + end Get_Next_Sub_Module; + + -- Instances + + package Instances_Table is new Tables + (Table_Component_Type => Instance_Record, + Table_Index_Type => Instance, + Table_Low_Bound => No_Instance, + Table_Initial => 1024); + + package Nets_Table is new Tables + (Table_Component_Type => Net_Record, + Table_Index_Type => Net, + Table_Low_Bound => No_Net, + Table_Initial => 1024); + + package Inputs_Table is new Tables + (Table_Component_Type => Input_Record, + Table_Index_Type => Input, + Table_Low_Bound => No_Input, + Table_Initial => 1024); + + package Params_Table is new Tables + (Table_Component_Type => Uns32, + Table_Index_Type => Param_Idx, + Table_Low_Bound => No_Param_Idx, + Table_Initial => 256); + + procedure Append_Instance (M_Ent : in out Module_Record; Inst : Instance) is + begin + if M_Ent.First_Instance = No_Instance then + M_Ent.First_Instance := Inst; + else + Instances_Table.Table (M_Ent.Last_Instance).Next_Instance := Inst; + end if; + M_Ent.Last_Instance := Inst; + end Append_Instance; + + function New_Instance_Internal (Parent : Module; + M : Module; + Name : Sname; + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + Nbr_Params : Param_Nbr; + Outputs_Desc : Port_Desc_Idx) + return Instance + is + pragma Assert (Is_Valid (Parent)); + pragma Assert (Is_Valid (M)); + Parent_Ent : Module_Record renames Modules_Table.Table (Parent); + Res : Instance; + Inputs : constant Input := Inputs_Table.Allocate (Natural (Nbr_Inputs)); + Outputs : constant Net := Nets_Table.Allocate (Natural (Nbr_Outputs)); + Params : constant Param_Idx := + Params_Table.Allocate (Natural (Nbr_Params)); + begin + Instances_Table.Append + ((Parent => Parent, + Next_Instance => No_Instance, + Klass => M, + Name => Name, + First_Param => Params, + First_Input => Inputs, + First_Output => Outputs)); + Res := Instances_Table.Last; + + -- Link instance + Append_Instance (Parent_Ent, Res); + + -- Setup inputs. + if Nbr_Inputs > 0 then + for I in 0 .. Nbr_Inputs - 1 loop + Inputs_Table.Table (Inputs + Input (I)) := + (Parent => Res, + Driver => No_Net, + Next_Sink => No_Input); + end loop; + end if; + + -- Setup nets. + if Nbr_Outputs > 0 then + for I in 0 .. Nbr_Outputs - 1 loop + Nets_Table.Table (Outputs + Net (I)) := + (Parent => Res, + First_Sink => No_Input, + W => Get_Port_Desc (Outputs_Desc + Port_Desc_Idx (I)).W); + end loop; + end if; + + -- Init params (to 0). + if Nbr_Params > 0 then + for I in 0 .. Nbr_Params - 1 loop + Params_Table.Table (Params + I) := 0; + end loop; + end if; + + return Res; + end New_Instance_Internal; + + function New_Instance (Parent : Module; M : Module; Name : Sname) + return Instance + is + Nbr_Inputs : constant Port_Nbr := Get_Nbr_Inputs (M); + Nbr_Outputs : constant Port_Nbr := Get_Nbr_Outputs (M); + Nbr_Params : constant Param_Nbr := Get_Nbr_Params (M); + begin + return New_Instance_Internal + (Parent, M, Name, Nbr_Inputs, Nbr_Outputs, Nbr_Params, + Get_Output_First_Desc (M)); + end New_Instance; + + function Create_Self_Instance (M : Module) return Instance + is + -- Can be done only once. + pragma Assert (Get_Self_Instance (M) = No_Instance); + Nbr_Inputs : constant Port_Nbr := Get_Nbr_Inputs (M); + Nbr_Outputs : constant Port_Nbr := Get_Nbr_Outputs (M); + begin + -- Swap inputs and outputs; no parameters. + return New_Instance_Internal + (M, M, Get_Name (M), Nbr_Outputs, Nbr_Inputs, 0, + Get_Input_First_Desc (M)); + end Create_Self_Instance; + + function Is_Valid (I : Instance) return Boolean is + begin + return I > No_Instance and then I <= Instances_Table.Last; + end Is_Valid; + + function Is_Self_Instance (I : Instance) return Boolean is + Irec : Instance_Record renames Instances_Table.Table (I); + begin + return Irec.Parent = Irec.Klass; + end Is_Self_Instance; + + procedure Free_Instance (Inst : Instance) + is + pragma Assert (Is_Valid (Inst)); + begin + Instances_Table.Table (Inst).Klass := Free_Module; + end Free_Instance; + + procedure Remove_Free_Instances (M : Module) + is + pragma Assert (Is_Valid (M)); + M_Ent : Module_Record renames Modules_Table.Table (M); + Inst : Instance; + begin + Inst := M_Ent.First_Instance; + + M_Ent.First_Instance := No_Instance; + M_Ent.Last_Instance := No_Instance; + + while Inst /= No_Instance loop + if Get_Id (Inst) /= Id_Free then + Append_Instance (M_Ent, Inst); + end if; + Inst := Get_Next_Instance (Inst); + end loop; + end Remove_Free_Instances; + + function Get_Module (Inst : Instance) return Module is + begin + pragma Assert (Is_Valid (Inst)); + return Instances_Table.Table (Inst).Klass; + end Get_Module; + + function Get_Instance_Name (Inst : Instance) return Sname is + begin + pragma Assert (Is_Valid (Inst)); + return Instances_Table.Table (Inst).Name; + end Get_Instance_Name; + + function Get_Instance_Parent (Inst : Instance) return Module is + begin + pragma Assert (Is_Valid (Inst)); + return Instances_Table.Table (Inst).Parent; + end Get_Instance_Parent; + + function Get_Next_Instance (Inst : Instance) return Instance is + begin + pragma Assert (Is_Valid (Inst)); + return Instances_Table.Table (Inst).Next_Instance; + end Get_Next_Instance; + + function Get_First_Output (Inst : Instance) return Net is + begin + pragma Assert (Is_Valid (Inst)); + return Instances_Table.Table (Inst).First_Output; + end Get_First_Output; + + function Get_Output (Inst : Instance; Idx : Port_Idx) return Net is + begin + pragma Assert (Is_Valid (Inst)); + pragma Assert (Idx < Get_Nbr_Outputs (Inst)); + return Instances_Table.Table (Inst).First_Output + Net (Idx); + end Get_Output; + + function Get_Input (Inst : Instance; Idx : Port_Idx) return Input is + begin + pragma Assert (Is_Valid (Inst)); + pragma Assert (Idx < Get_Nbr_Inputs (Inst)); + return Instances_Table.Table (Inst).First_Input + Input (Idx); + end Get_Input; + + -- Nets + + function Is_Valid (N : Net) return Boolean is + begin + return N > No_Net and then N <= Nets_Table.Last; + end Is_Valid; + + function Get_Net_Parent (O : Net) return Instance is + begin + pragma Assert (Is_Valid (O)); + return Nets_Table.Table (O).Parent; + end Get_Net_Parent; + + function Get_Port_Idx (O : Net) return Port_Idx + is + pragma Assert (Is_Valid (O)); + Parent : constant Instance := Get_Parent (O); + begin + return Port_Idx (O - Instances_Table.Table (Parent).First_Output); + end Get_Port_Idx; + + function Get_First_Sink (O : Net) return Input is + begin + pragma Assert (Is_Valid (O)); + return Nets_Table.Table (O).First_Sink; + end Get_First_Sink; + + function Get_Width (N : Net) return Width + is + pragma Assert (Is_Valid (N)); + begin + return Nets_Table.Table (N).W; + end Get_Width; + + procedure Set_Width (N : Net; W : Width) + is + pragma Assert (Is_Valid (N)); + begin + if Nets_Table.Table (N).W /= No_Width then + raise Internal_Error; + end if; + Nets_Table.Table (N).W := W; + end Set_Width; + + + -- Inputs + + function Is_Valid (N : Input) return Boolean is + begin + return N > No_Input and then N <= Inputs_Table.Last; + end Is_Valid; + + function Get_Input_Parent (I : Input) return Instance is + begin + pragma Assert (Is_Valid (I)); + return Inputs_Table.Table (I).Parent; + end Get_Input_Parent; + + function Get_Port_Idx (I : Input) return Port_Idx + is + pragma Assert (Is_Valid (I)); + Parent : constant Instance := Get_Parent (I); + begin + return Port_Idx (I - Instances_Table.Table (Parent).First_Input); + end Get_Port_Idx; + + function Get_Driver (I : Input) return Net is + begin + pragma Assert (Is_Valid (I)); + return Inputs_Table.Table (I).Driver; + end Get_Driver; + + function Get_Next_Sink (I : Input) return Input is + begin + pragma Assert (Is_Valid (I)); + return Inputs_Table.Table (I).Next_Sink; + end Get_Next_Sink; + + + -- Port_Desc + + package Port_Desc_Table is new Tables + (Table_Component_Type => Port_Desc, + Table_Index_Type => Port_Desc_Idx, + Table_Low_Bound => No_Port_Desc_Idx, + Table_Initial => 1024); + + function Get_Port_Desc (Idx : Port_Desc_Idx) return Port_Desc is + begin + return Port_Desc_Table.Table (Idx); + end Get_Port_Desc; + + function Get_Input_Desc (M : Module; I : Port_Idx) return Port_Desc + is + F : constant Port_Desc_Idx := Get_Input_First_Desc (M); + pragma Assert (I < Get_Nbr_Inputs (M)); + begin + return Port_Desc_Table.Table (F + Port_Desc_Idx (I)); + end Get_Input_Desc; + + function Get_Output_Desc (M : Module; O : Port_Idx) return Port_Desc + is + F : constant Port_Desc_Idx := Get_Output_First_Desc (M); + pragma Assert (O < Get_Nbr_Outputs (M)); + begin + return Port_Desc_Table.Table (F + Port_Desc_Idx (O)); + end Get_Output_Desc; + + procedure Set_Port_Desc (M : Module; + Input_Descs : Port_Desc_Array; + Output_Descs : Port_Desc_Array) + is + pragma Assert (Is_Valid (M)); + pragma Assert (Input_Descs'Length = Get_Nbr_Inputs (M)); + pragma Assert (Output_Descs'Length = Get_Nbr_Outputs (M)); + begin + pragma Assert + (Modules_Table.Table (M).First_Port_Desc = No_Port_Desc_Idx); + + Modules_Table.Table (M).First_Port_Desc := Port_Desc_Table.Last + 1; + + for I of Input_Descs loop + pragma Assert (I.Dir = Port_In); + Port_Desc_Table.Append (I); + end loop; + + for O of Output_Descs loop + pragma Assert (O.Dir in Port_Outs); + Port_Desc_Table.Append (O); + end loop; + end Set_Port_Desc; + + -- Param_Desc + + package Param_Desc_Table is new Tables + (Table_Component_Type => Param_Desc, + Table_Index_Type => Param_Desc_Idx, + Table_Low_Bound => No_Param_Desc_Idx, + Table_Initial => 256); + + procedure Set_Param_Desc (M : Module; + Params : Param_Desc_Array) + is + pragma Assert (Is_Valid (M)); + pragma Assert (Params'Length = Get_Nbr_Params (M)); + begin + pragma Assert + (Modules_Table.Table (M).First_Param_Desc = No_Param_Desc_Idx); + + Modules_Table.Table (M).First_Param_Desc := Param_Desc_Table.Last + 1; + + for P of Params loop + Param_Desc_Table.Append (P); + end loop; + end Set_Param_Desc; + + function Get_Param_Desc (M : Module; Param : Param_Idx) return Param_Desc + is + pragma Assert (Is_Valid (M)); + pragma Assert (Param < Get_Nbr_Params (M)); + begin + return Param_Desc_Table.Table + (Modules_Table.Table (M).First_Param_Desc + Param_Desc_Idx (Param)); + end Get_Param_Desc; + + function Get_Param_Idx (Inst : Instance; Param : Param_Idx) return Param_Idx + is + pragma Assert (Is_Valid (Inst)); + pragma Assert (Param < Get_Nbr_Params (Inst)); + begin + return Instances_Table.Table (Inst).First_Param + Param; + end Get_Param_Idx; + + function Get_Param_Uns32 (Inst : Instance; Param : Param_Idx) return Uns32 + is + pragma Assert (Is_Valid (Inst)); + M : constant Module := Get_Module (Inst); + pragma Assert (Param < Get_Nbr_Params (M)); + pragma Assert (Get_Param_Desc (M, Param).Typ = Param_Uns32); + begin + return Params_Table.Table (Get_Param_Idx (Inst, Param)); + end Get_Param_Uns32; + + procedure Set_Param_Uns32 (Inst : Instance; Param : Param_Idx; Val : Uns32) + is + pragma Assert (Is_Valid (Inst)); + M : constant Module := Get_Module (Inst); + pragma Assert (Param < Get_Nbr_Params (M)); + pragma Assert (Get_Param_Desc (M, Param).Typ = Param_Uns32); + begin + Params_Table.Table (Get_Param_Idx (Inst, Param)) := Val; + end Set_Param_Uns32; + + procedure Connect (I : Input; O : Net) + is + pragma Assert (Is_Valid (I)); + pragma Assert (Is_Valid (O)); + -- Check Width compatibility + -- pragma assert (get_width (i) = get_width (o)); + pragma Assert (Get_Driver (I) = No_Net); + I_Ent : Input_Record renames Inputs_Table.Table (I); + O_Ent : Net_Record renames Nets_Table.Table (O); + begin + I_Ent.Driver := O; + I_Ent.Next_Sink := O_Ent.First_Sink; + O_Ent.First_Sink := I; + end Connect; + + procedure Disconnect (I : Input) + is + pragma Assert (Is_Valid (I)); + Drv : constant Net := Get_Driver (I); + pragma Assert (Drv /= No_Net); + Next_Sink : constant Input := Get_Next_Sink (I); + I_Ent : Input_Record renames Inputs_Table.Table (I); + D_Ent : Net_Record renames Nets_Table.Table (Drv); + S, N_S : Input; + begin + I_Ent.Next_Sink := No_Input; + I_Ent.Driver := No_Net; + + if D_Ent.First_Sink = I then + -- Was the first sink. + D_Ent.First_Sink := Next_Sink; + else + -- Walk + S := D_Ent.First_Sink; + loop + pragma Assert (Is_Valid (S)); + N_S := Get_Next_Sink (S); + if N_S = I then + Inputs_Table.Table (S).Next_Sink := Next_Sink; + exit; + else + S := N_S; + end if; + end loop; + end if; + end Disconnect; + + procedure Redirect_Inputs (Old : Net; N : Net) + is + First_I, I : Input; + Prev_I : Input; + begin + First_I := Get_First_Sink (Old); + if First_I = No_Input then + return; + end if; + + I := First_I; + Prev_I := No_Input; + while I /= No_Input loop + declare + I_Rec : Input_Record renames Inputs_Table.Table (I); + begin + pragma Assert (I_Rec.Driver = Old); + I_Rec.Driver := N; + + if Prev_I /= No_Input then + Inputs_Table.Table (Prev_I).Next_Sink := I; + end if; + Prev_I := I; + + I := I_Rec.Next_Sink; + end; + end loop; + if Prev_I /= No_Input then + Inputs_Table.Table (Prev_I).Next_Sink := Get_First_Sink (N); + Nets_Table.Table (N).First_Sink := First_I; + end if; + end Redirect_Inputs; + +begin + -- Initialize snames_table: create the first entry for No_Sname. + Snames_Table.Append ((Kind => Sname_Artificial, + Prefix => No_Sname, + Suffix => 0)); + pragma Assert (Snames_Table.Last = No_Sname); + + Modules_Table.Append ((Parent => No_Module, + Name => No_Sname, + Id => Id_None, + First_Port_Desc => No_Port_Desc_Idx, + Nbr_Inputs => 0, + Nbr_Outputs => 0, + First_Param_Desc => No_Param_Desc_Idx, + Nbr_Params => 0, + First_Sub_Module => No_Module, + Last_Sub_Module => No_Module, + Next_Sub_Module => No_Module, + First_Instance => No_Instance, + Last_Instance => No_Instance)); + pragma Assert (Modules_Table.Last = No_Module); + + Modules_Table.Append ((Parent => No_Module, + Name => No_Sname, + Id => Id_Free, + First_Port_Desc => No_Port_Desc_Idx, + Nbr_Inputs => 0, + Nbr_Outputs => 0, + First_Param_Desc => No_Param_Desc_Idx, + Nbr_Params => 0, + First_Sub_Module => No_Module, + Last_Sub_Module => No_Module, + Next_Sub_Module => No_Module, + First_Instance => No_Instance, + Last_Instance => No_Instance)); + pragma Assert (Modules_Table.Last = Free_Module); + + Instances_Table.Append ((Parent => No_Module, + Next_Instance => No_Instance, + Klass => No_Module, + Name => No_Sname, + First_Param => No_Param_Idx, + First_Input => No_Input, + First_Output => No_Net)); + pragma Assert (Instances_Table.Last = No_Instance); + + Nets_Table.Append ((Parent => No_Instance, + First_Sink => No_Input, + W => 0)); + pragma Assert (Nets_Table.Last = No_Net); + + Inputs_Table.Append ((Parent => No_Instance, + Driver => No_Net, + Next_Sink => No_Input)); + pragma Assert (Inputs_Table.Last = No_Input); + + Port_Desc_Table.Append ((Name => No_Sname, + W => 0, + Dir => Port_In, + Left => 0, + Right => 0)); + pragma Assert (Port_Desc_Table.Last = No_Port_Desc_Idx); + + Param_Desc_Table.Append ((Name => No_Sname, + Typ => Param_Uns32)); + pragma Assert (Param_Desc_Table.Last = No_Param_Desc_Idx); + + Params_Table.Append (0); + pragma Assert (Params_Table.Last = No_Param_Idx); +end Netlists; diff --git a/src/synth/netlists.ads b/src/synth/netlists.ads new file mode 100644 index 000000000..53e56a8c0 --- /dev/null +++ b/src/synth/netlists.ads @@ -0,0 +1,337 @@ +-- Netlist. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; + +package Netlists is + -- Names. + -- As there are many artificial and hierarchical names in a netlist, names + -- are not flat: it is possible to create a new name using an existing one + -- without copying the whole prefix. + type Sname_Kind is + ( + -- The name adds a suffix to an existing name. Simple names (without + -- prefix) are in this kind, with a null prefix. + Sname_User, + Sname_Artificial, + + -- Create a new version of an existing prefix. + Sname_Version + ); + pragma Convention (C, Sname_Kind); + + type Sname is private; + No_Sname : constant Sname; + + -- Create an Sname. + -- There is no unification: these routines always create a new name. There + -- is no check that the name already exists, so these routines may create + -- a duplicate name. Callers must ensure they create uniq names. + function New_Sname_User (Id : Name_Id) return Sname; + function New_Sname_Artificial (Id : Name_Id) return Sname; + function New_Sname (Prefix : Sname; Suffix : Name_Id) return Sname; + function New_Sname_Version (Prefix : Sname; Ver : Uns32) return Sname; + + -- Read the content of an Sname. + function Get_Sname_Kind (Name : Sname) return Sname_Kind; + function Get_Sname_Prefix (Name : Sname) return Sname; + function Get_Sname_Suffix (Name : Sname) return Name_Id; + function Get_Sname_Version (Name : Sname) return Uns32; + function Get_Sname_Num (Name : Sname) return Uns32; + + type Net is private; + No_Net : constant Net; + + type Module is private; + No_Module : constant Module; + + type Instance is private; + No_Instance : constant Instance; + + -- Witdh of a net, ie number of bits. + -- No_Width (value 0) is reserved to mean unknown. This is allowed only to + -- describe the width of predefined gates (like and) so that the same + -- module can be used for any width. + subtype Width is Uns32; + No_Width : constant Width := 0; + + type Port_Kind is (Port_In, Port_Out, Port_Inout); + + -- Inout are considered as output. + subtype Port_Outs is Port_Kind range Port_Out .. Port_Inout; + + -- Each module has a numeric identifier that can be used to easily identify + -- a module. Gates (and, or, ...) have reverved identifiers. + type Module_Id is new Uns32; + + -- Reserved id for no identifier. + Id_None : constant Module_Id := 0; + + -- Unused instance: free instance but still linked. + Id_Free : constant Module_Id := 1; + + -- Reserved id for a design (top-level module without ports that contains + -- other modules). + Id_Design : constant Module_Id := 2; + + -- First id for user. + Id_User_None : constant Module_Id := 128; + Id_User_First : constant Module_Id := Id_User_None + 1; + + -- Port index. Starts at 0. + type Port_Nbr is new Uns32; + subtype Port_Idx is Port_Nbr range 0 .. Port_Nbr'Last - 1; + + type Port_Desc is record + -- Name of the port. + Name : Sname; + + -- Port width (number of bits). + W : Width; + + -- Direction. + Dir : Port_Kind; + + -- For a bus: left and right bounds of the bus, ie [L:R]. + Left : Int32; + Right : Int32; + end record; + + type Port_Desc_Array is array (Port_Idx range <>) of Port_Desc; + + type Param_Idx is new Uns32; + No_Param_Idx : constant Param_Idx := 0; + + subtype Param_Nbr is Param_Idx range 0 .. Param_Idx'Last - 1; + + type Param_Type is + (Param_Invalid, + + Param_Uns32 + -- An unsigned 32 bit value. + ); + pragma Convention (C, Param_Type); + + type Param_Desc is record + -- Name of the parameter + Name : Sname; + + -- Type of the parameter + Typ : Param_Type; + end record; + + type Param_Desc_Array is array (Param_Idx range <>) of Param_Desc; + + -- Module. + -- + -- A module represent an uninstantiated netlist. It is composed of nets + -- and instances + -- + -- From the outside, a module has ports (inputs and outputs), and + -- optionally parameters. A module must have at least one port. + -- + -- In a module, there is a special instance (the self one) one that + -- represent the ports of the module itself, but with the opposite + -- direction. Using this trick, there is no difference between ports of + -- instances and ports of the module itself. + function New_Design (Name : Sname) return Module; + function New_User_Module (Parent : Module; + Name : Sname; + Id : Module_Id; + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + Nbr_Params : Param_Nbr := 0) + return Module; + procedure Set_Port_Desc (M : Module; + Input_Descs : Port_Desc_Array; + Output_Descs : Port_Desc_Array); + procedure Set_Param_Desc (M : Module; + Params : Param_Desc_Array); + + -- Create the self instance, once ports are defined. This is required if + -- the internal netlist will be defined. + function Create_Self_Instance (M : Module) return Instance; + + function Get_Module_Name (M : Module) return Sname; + function Get_Name (M : Module) return Sname renames Get_Module_Name; + function Get_Id (M : Module) return Module_Id; + + function Get_Nbr_Inputs (M : Module) return Port_Nbr; + function Get_Nbr_Outputs (M : Module) return Port_Nbr; + + function Get_Nbr_Params (M : Module) return Param_Nbr; + + function Get_Input_Desc (M : Module; I : Port_Idx) return Port_Desc; + function Get_Output_Desc (M : Module; O : Port_Idx) return Port_Desc; + + function Get_Param_Desc (M : Module; Param : Param_Idx) return Param_Desc; + + function Get_Self_Instance (M : Module) return Instance; + function Get_First_Instance (M : Module) return Instance; + + -- Linked list of sub-modules. + -- Use Modules to iterate. + function Get_First_Sub_Module (M : Module) return Module; + function Get_Next_Sub_Module (M : Module) return Module; + + type Input is private; + No_Input : constant Input; + + -- Instance + function New_Instance (Parent : Module; M : Module; Name : Sname) + return Instance; + + -- Mark INST as free, but keep it in the module. + -- Use Remove_Free_Instances for a cleanup. + procedure Free_Instance (Inst : Instance); + + -- Unlink all free instances of M. + procedure Remove_Free_Instances (M : Module); + + function Is_Self_Instance (I : Instance) return Boolean; + function Get_Module (Inst : Instance) return Module; + function Get_Instance_Name (Inst : Instance) return Sname; + function Get_Name (Inst : Instance) return Sname renames Get_Instance_Name; + function Get_Instance_Parent (Inst : Instance) return Module; + function Get_Parent (Inst : Instance) return Module + renames Get_Instance_Parent; + function Get_Output (Inst : Instance; Idx : Port_Idx) return Net; + function Get_Input (Inst : Instance; Idx : Port_Idx) return Input; + function Get_Next_Instance (Inst : Instance) return Instance; + + function Get_Param_Uns32 (Inst : Instance; Param : Param_Idx) return Uns32; + procedure Set_Param_Uns32 (Inst : Instance; Param : Param_Idx; Val : Uns32); + + -- Input + function Get_Input_Parent (I : Input) return Instance; + function Get_Parent (I : Input) return Instance renames Get_Input_Parent; + function Get_Port_Idx (I : Input) return Port_Idx; + function Get_Driver (I : Input) return Net; + function Get_Next_Sink (I : Input) return Input; + + -- Net (Output) + function Get_Net_Parent (O : Net) return Instance; + function Get_Parent (O : Net) return Instance renames Get_Net_Parent; + function Get_Port_Idx (O : Net) return Port_Idx; + function Get_First_Sink (O : Net) return Input; + function Get_Width (N : Net) return Width; + + -- Set the width of a net. This operation is possible only if the width + -- is unknown. + procedure Set_Width (N : Net; W : Width); + + -- Connections. + procedure Connect (I : Input; O : Net); + procedure Disconnect (I : Input); + + -- Reconnect all sinks of OLD to N. + procedure Redirect_Inputs (Old : Net; N : Net); +private + type Sname is new Uns32 range 0 .. 2**30 - 1; + No_Sname : constant Sname := 0; + + -- We don't care about C compatible representation of Sname_Record. + pragma Warnings (Off, "*convention*"); + type Sname_Record is record + Kind : Sname_Kind; + Prefix : Sname; + Suffix : Uns32; + end record; + pragma Pack (Sname_Record); + for Sname_Record'Size use 2*32; + pragma Warnings (On, "*convention*"); + + type Module is new Uns32; + No_Module : constant Module := 0; + Free_Module : constant Module := 1; + + function Is_Valid (M : Module) return Boolean; + + type Port_Desc_Idx is new Uns32; + No_Port_Desc_Idx : constant Port_Desc_Idx := 0; + + type Param_Desc_Idx is new Uns32; + No_Param_Desc_Idx : constant Param_Desc_Idx := 0; + + type Module_Record is record + Parent : Module; + Name : Sname; + Id : Module_Id; + First_Port_Desc : Port_Desc_Idx; + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + First_Param_Desc : Param_Desc_Idx; + Nbr_Params : Param_Nbr; + + -- First sub-module child. + First_Sub_Module : Module; + Last_Sub_Module : Module; + + -- Sub-module brother. + Next_Sub_Module : Module; + + -- The self instance is the first instance. + First_Instance : Instance; + Last_Instance : Instance; + end record; + + function Get_First_Port_Desc (M : Module) return Port_Desc_Idx; + function Get_First_Output (Inst : Instance) return Net; + function Get_Port_Desc (Idx : Port_Desc_Idx) return Port_Desc; + + type Instance is new Uns32; + No_Instance : constant Instance := 0; + + function Is_Valid (I : Instance) return Boolean; + + type Instance_Record is record + -- The instance is instantiated in Parent. + Parent : Module; + Next_Instance : Instance; + + -- For a self-instance, Klass is equal to Parent, and Name is No_Sname. + Klass : Module; + Name : Sname; + + First_Param : Param_Idx; + First_Input : Input; + First_Output : Net; + end record; + + type Input is new Uns32; + No_Input : constant Input := 0; + + type Input_Record is record + Parent : Instance; + Driver : Net; + Next_Sink : Input; + end record; + + type Net is new Uns32; + No_Net : constant Net := 0; + + function Is_Valid (N : Net) return Boolean; + + type Net_Record is record + Parent : Instance; + First_Sink : Input; + W : Width; + end record; +end Netlists; diff --git a/src/synth/synth-context.adb b/src/synth/synth-context.adb new file mode 100644 index 000000000..92edc3e34 --- /dev/null +++ b/src/synth/synth-context.adb @@ -0,0 +1,229 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Unchecked_Deallocation; + +with Types; use Types; +with Grt.Types; use Grt.Types; +with Errorout; use Errorout; + +with Annotations; use Annotations; +with Execution; +with Iir_Values; use Iir_Values; + +with Netlists.Builders; use Netlists.Builders; + +with Iirs_Utils; use Iirs_Utils; +with Std_Package; +with Ieee.Std_Logic_1164; + +with Synth.Types; use Synth.Types; +with Synth.Errors; use Synth.Errors; +with Synth.Expr; use Synth.Expr; + +package body Synth.Context is + function Make_Instance (Sim_Inst : Block_Instance_Acc) + return Synth_Instance_Acc + is + Res : Synth_Instance_Acc; + begin + Res := new Synth_Instance_Type'(Max_Objs => Sim_Inst.Max_Objs, + M => No_Module, + Name => No_Sname, + Sim => Sim_Inst, + Objects => (others => null)); + pragma Assert (Instance_Map (Sim_Inst.Id) = null); + Instance_Map (Sim_Inst.Id) := Res; + return Res; + end Make_Instance; + + procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc) + is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Synth_Instance_Type, Synth_Instance_Acc); + begin + Instance_Map (Synth_Inst.Sim.Id) := null; + Deallocate (Synth_Inst); + end Free_Instance; + + function Alloc_Wire (Kind : Wire_Kind; Obj : Iir; Rng : Value_Range_Acc) + return Value_Acc is + begin + Wire_Id_Table.Append ((Kind => Kind, + Mark_Flag => False, + Decl => Obj, + Gate => No_Net, + Cur_Assign => No_Assign)); + return Create_Value_Wire (Wire_Id_Table.Last, Rng); + end Alloc_Wire; + + function Alloc_Object + (Kind : Wire_Kind; Obj : Iir; Val : Iir_Value_Literal_Acc) + return Value_Acc + is + Obj_Type : constant Iir := Get_Type (Obj); + Btype : constant Iir := Get_Base_Type (Obj_Type); + begin + case Get_Kind (Btype) is + when Iir_Kind_Enumeration_Type_Definition => + if Is_Bit_Type (Btype) then + return Alloc_Wire (Kind, Obj, null); + else + -- TODO + raise Internal_Error; + end if; + when Iir_Kind_Array_Type_Definition => + -- Well known array types. + if Btype = Ieee.Std_Logic_1164.Std_Logic_Vector_Type + or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Vector_Type + then + return Alloc_Wire + (Kind, Obj, Bounds_To_Range (Val.Bounds.D (1))); + end if; + if Is_Bit_Type (Get_Element_Subtype (Btype)) + and then Get_Nbr_Dimensions (Btype) = 1 + then + -- A vector of bits. + return Alloc_Wire + (Kind, Obj, Bounds_To_Range (Val.Bounds.D (1))); + else + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + end Alloc_Object; + + procedure Make_Object (Syn_Inst : Synth_Instance_Acc; + Kind : Wire_Kind; + Obj : Iir) + is + Otype : constant Iir := Get_Type (Obj); + Slot : constant Object_Slot_Type := Get_Info (Obj).Slot; + Val : Value_Acc; + begin + Val := Alloc_Object (Kind, Obj, Syn_Inst.Sim.Objects (Slot)); + if Val = null then + Error_Msg_Synth (+Obj, "%n is not supported", +Otype); + return; + end if; + + pragma Assert (Syn_Inst.Objects (Slot) = null); + Syn_Inst.Objects (Slot) := Val; + end Make_Object; + + function Get_Net (Val : Value_Acc) return Net is + begin + case Val.Kind is + when Value_Wire => + return Get_Current_Value (Val.W); + when Value_Net => + return Val.N; + when Value_Lit => + case Val.Lit.Kind is + when Iir_Value_B1 => + pragma Assert + (Val.Lit_Type = Std_Package.Boolean_Type_Definition + or else Val.Lit_Type = Std_Package.Bit_Type_Definition); + return Build_Const_UB32 + (Build_Context, Ghdl_B1'Pos (Val.Lit.B1), 1); + when Iir_Value_E8 => + if Is_Bit_Type (Val.Lit_Type) then + declare + V, Xz : Uns32; + begin + To_Logic (Val.Lit, V, Xz); + if Xz = 0 then + return Build_Const_UB32 (Build_Context, V, 1); + else + return Build_Const_UL32 (Build_Context, V, Xz, 1); + end if; + end; + else + -- State machine. + raise Internal_Error; + end if; + when Iir_Value_I64 => + if Val.Lit.I64 >= 0 then + for I in 1 .. 32 loop + if Val.Lit.I64 < (2**I) then + return Build_Const_UB32 + (Build_Context, Uns32 (Val.Lit.I64), Width (I)); + end if; + end loop; + -- Need Uconst64 + raise Internal_Error; + else + -- Need Sconst32/Sconst64 + raise Internal_Error; + end if; + when Iir_Value_Array => + if Is_Vector_Type (Val.Lit_Type) then + if Val.Lit.Bounds.D (1).Length <= 32 then + declare + Len : constant Iir_Index32 := Val.Lit.Val_Array.Len; + R_Val, R_Xz : Uns32; + V, Xz : Uns32; + begin + R_Val := 0; + R_Xz := 0; + for I in 1 .. Len loop + To_Logic (Val.Lit.Val_Array.V (I), V, Xz); + R_Val := + R_Val or Shift_Left (V, Natural (Len - I)); + R_Xz := + R_Xz or Shift_Left (Xz, Natural (Len - I)); + end loop; + if R_Xz = 0 then + return Build_Const_UB32 + (Build_Context, R_Val, Uns32 (Len)); + else + return Build_Const_UL32 + (Build_Context, R_Val, R_Xz, Uns32 (Len)); + end if; + end; + else + -- Need Uconst64 / UconstBig + raise Internal_Error; + end if; + else + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end Get_Net; + + function Get_Value (Inst : Synth_Instance_Acc; Obj : Iir) return Value_Acc + is + Slot : constant Object_Slot_Type := Get_Info (Obj).Slot; + Sim_Inst : constant Block_Instance_Acc := + Execution.Get_Instance_For_Slot (Inst.Sim, Obj); + Val : Value_Acc; + begin + Val := Instance_Map (Sim_Inst.Id).Objects (Slot); + pragma Assert (Val /= null); + return Val; + end Get_Value; + +end Synth.Context; diff --git a/src/synth/synth-context.ads b/src/synth/synth-context.ads new file mode 100644 index 000000000..ac8b881d9 --- /dev/null +++ b/src/synth/synth-context.ads @@ -0,0 +1,50 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Synth.Environment; use Synth.Environment; +with Synth.Values; use Synth.Values; +with Elaboration; use Elaboration; +with Netlists; use Netlists; +with Netlists.Builders; +with Iirs; use Iirs; + +package Synth.Context is + type Instance_Map_Array is array (Block_Instance_Id range <>) + of Synth_Instance_Acc; + type Instance_Map_Array_Acc is access Instance_Map_Array; + + -- Map between simulation instance and synthesis instance. + Instance_Map : Instance_Map_Array_Acc; + + Build_Context : Netlists.Builders.Context_Acc; + + function Make_Instance (Sim_Inst : Block_Instance_Acc) + return Synth_Instance_Acc; + procedure Free_Instance (Synth_Inst : in out Synth_Instance_Acc); + + procedure Make_Object (Syn_Inst : Synth_Instance_Acc; + Kind : Wire_Kind; + Obj : Iir); + + function Get_Net (Val : Value_Acc) return Net; + + function Get_Value (Inst : Synth_Instance_Acc; Obj : Iir) return Value_Acc; + +end Synth.Context; diff --git a/src/synth/synth-decls.adb b/src/synth/synth-decls.adb new file mode 100644 index 000000000..65459fd7e --- /dev/null +++ b/src/synth/synth-decls.adb @@ -0,0 +1,116 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Netlists; use Netlists; +with Netlists.Builders; use Netlists.Builders; +with Errorout; use Errorout; +with Synth.Context; use Synth.Context; +with Synth.Types; use Synth.Types; +with Synth.Environment; use Synth.Environment; +with Iir_Values; use Iir_Values; +with Annotations; use Annotations; + +package body Synth.Decls is + procedure Create_Var_Wire + (Syn_Inst : Synth_Instance_Acc; Decl : Iir; Init : Iir_Value_Literal_Acc) + is + Val : constant Value_Acc := Get_Value (Syn_Inst, Decl); + Value : Net; + Ival : Net; + W : Width; + Name : Sname; + begin + case Val.Kind is + when Value_Wire => + W := Get_Width (Syn_Inst, Get_Type (Decl)); + Name := New_Sname (Syn_Inst.Name, Get_Identifier (Decl)); + if Init /= null then + Ival := Get_Net (Create_Value_Lit (Init, Get_Type (Decl))); + pragma Assert (Get_Width (Ival) = W); + Value := Build_Isignal (Build_Context, Name, Ival); + else + Value := Build_Signal (Build_Context, Name, W); + end if; + Wire_Id_Table.Table (Val.W).Gate := Value; + when others => + raise Internal_Error; + end case; + end Create_Var_Wire; + + procedure Synth_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Variable_Declaration => + declare + Def : constant Iir := Get_Default_Value (Decl); + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Init : Iir_Value_Literal_Acc; + begin + Make_Object (Syn_Inst, Wire_Variable, Decl); + if Is_Valid (Def) then + Init := Syn_Inst.Sim.Objects (Slot); + else + Init := null; + end if; + Create_Var_Wire (Syn_Inst, Decl, Init); + end; + when Iir_Kind_Interface_Variable_Declaration => + -- Ignore default value. + Make_Object (Syn_Inst, Wire_Variable, Decl); + Create_Var_Wire (Syn_Inst, Decl, null); + when Iir_Kind_Signal_Declaration => + declare + Def : constant Iir := Get_Default_Value (Decl); + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Init : Iir_Value_Literal_Acc; + begin + Make_Object (Syn_Inst, Wire_Signal, Decl); + if Is_Valid (Def) then + Init := Syn_Inst.Sim.Objects (Slot + 1); + else + Init := null; + end if; + Create_Var_Wire (Syn_Inst, Decl, Init); + end; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- TODO: elaborate interfaces + null; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when others => + Error_Kind ("synth_declaration", Decl); + end case; + end Synth_Declaration; + + procedure Synth_Declarations (Syn_Inst : Synth_Instance_Acc; Decls : Iir) + is + Decl : Iir; + begin + Decl := Decls; + while Is_Valid (Decl) loop + Synth_Declaration (Syn_Inst, Decl); + + Decl := Get_Chain (Decl); + end loop; + end Synth_Declarations; +end Synth.Decls; diff --git a/src/synth/synth-decls.ads b/src/synth/synth-decls.ads new file mode 100644 index 000000000..119f8bd07 --- /dev/null +++ b/src/synth/synth-decls.ads @@ -0,0 +1,28 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Iirs; use Iirs; +with Synth.Values; use Synth.Values; + +package Synth.Decls is + procedure Synth_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Iir); + + procedure Synth_Declarations (Syn_Inst : Synth_Instance_Acc; Decls : Iir); +end Synth.Decls; diff --git a/src/synth/synth-environment-debug.adb b/src/synth/synth-environment-debug.adb new file mode 100644 index 000000000..b1ac137c5 --- /dev/null +++ b/src/synth/synth-environment-debug.adb @@ -0,0 +1,76 @@ +-- Debug utilities for synthesis environment. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Text_IO; use Ada.Text_IO; +with Netlists.Dump; use Netlists.Dump; + +package body Synth.Environment.Debug is + procedure Dump_Wire_Id (Id : Wire_Id) + is + W_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Id); + begin + Put ("Wire:" & Wire_Id'Image (Id)); + Put_Line (" kind: " & Wire_Kind'Image (W_Rec.Kind)); + Put_Line (" decl:" & Source.Syn_Src'Image (W_Rec.Decl)); + Put (" Init: "); + Dump_Net_Name (W_Rec.Gate); + New_Line; + Put_Line (" cur_assign:" & Assign'Image (W_Rec.Cur_Assign)); + end Dump_Wire_Id; + + procedure Dump_Assign (Asgn : Assign) + is + procedure Dump_Value (N : Net) is + begin + if N /= No_Net then + Dump_Net_Name (N); + Put (" := "); + Disp_Instance (Get_Parent (N), False); + else + Put ("unassigned"); + end if; + end Dump_Value; + Rec : Assign_Record renames Assign_Table.Table (Asgn); + begin + Put ("Assign" & Assign'Image (Asgn)); + Put (" Id:" & Wire_Id'Image (Rec.Id)); + Put (", prev_assign:" & Assign'Image (Rec.Prev)); + Put (", phi:" & Phi_Id'Image (Rec.Phi)); + Put (", chain:" & Assign'Image (Rec.Chain)); + New_Line; + Put (" value: "); + Dump_Value (Rec.Value); + New_Line; + end Dump_Assign; + + procedure Dump_Phi (Id : Phi_Id) + is + Phi : Phi_Type renames Phis_Table.Table (Id); + Asgn : Assign; + begin + Put ("phi_id:" & Phi_Id'Image (Id) & ", nbr:" & Uns32'Image (Phi.Nbr)); + New_Line; + Asgn := Phi.First; + while Asgn /= No_Assign loop + Dump_Assign (Asgn); + Asgn := Get_Assign_Chain (Asgn); + end loop; + end Dump_Phi; +end Synth.Environment.Debug; diff --git a/src/synth/synth-environment-debug.ads b/src/synth/synth-environment-debug.ads new file mode 100644 index 000000000..55bbf3d66 --- /dev/null +++ b/src/synth/synth-environment-debug.ads @@ -0,0 +1,25 @@ +-- Debug utilities for synthesis environment. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Synth.Environment.Debug is + procedure Dump_Wire_Id (Id : Wire_Id); + procedure Dump_Assign (Asgn : Assign); + procedure Dump_Phi (Id : Phi_Id); +end Synth.Environment.Debug; diff --git a/src/synth/synth-environment.adb b/src/synth/synth-environment.adb new file mode 100644 index 000000000..e02cf12d3 --- /dev/null +++ b/src/synth/synth-environment.adb @@ -0,0 +1,334 @@ +-- Environment definition 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Utils; use Netlists.Utils; +with Netlists.Gates; use Netlists.Gates; +with Netlists.Builders; use Netlists.Builders; +with Synth.Inference; + +package body Synth.Environment is + function Get_Wire_Id (W : Assign) return Wire_Id is + begin + return Assign_Table.Table (W).Id; + end Get_Wire_Id; + + function Get_Assign_Prev (Asgn : Assign) return Assign is + begin + return Assign_Table.Table (Asgn).Prev; + end Get_Assign_Prev; + + function Get_Assign_Chain (Asgn : Assign) return Assign is + begin + return Assign_Table.Table (Asgn).Chain; + end Get_Assign_Chain; + + procedure Set_Assign_Chain (Asgn : Assign; Chain : Assign) is + begin + Assign_Table.Table (Asgn).Chain := Chain; + end Set_Assign_Chain; + + procedure Push_Phi is + begin + Phis_Table.Append ((First => No_Assign, + Nbr => 0)); + end Push_Phi; + + procedure Pop_Phi (Phi : out Phi_Type) + is + Cur_Phi : constant Phi_Id := Current_Phi; + Asgn : Assign; + begin + Phi := Phis_Table.Table (Cur_Phi); + Phis_Table.Decrement_Last; + + -- Point to previous wires. + Asgn := Phi.First; + while Asgn /= No_Assign loop + pragma Assert (Assign_Table.Table (Asgn).Phi = Cur_Phi); + Wire_Id_Table.Table (Get_Wire_Id (Asgn)).Cur_Assign := + Get_Assign_Prev (Asgn); + Asgn := Get_Assign_Chain (Asgn); + end loop; + end Pop_Phi; + + procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc) + is + Phi : Phi_Type; + Asgn : Assign; + begin + Pop_Phi (Phi); + Asgn := Phi.First; + while Asgn /= No_Assign loop + declare + Asgn_Rec : Assign_Record renames Assign_Table.Table (Asgn); + Outport : constant Net := Wire_Id_Table.Table (Asgn_Rec.Id).Gate; + -- Must be connected to an Id_Output or Id_Signal + pragma Assert (Outport /= No_Net); + Gate_Inst : Instance; + Gate_In : Input; + Drv : Net; + New_Sig : Net; + begin + Gate_Inst := Get_Parent (Outport); + Gate_In := Get_Input (Gate_Inst, 0); + Drv := Get_Driver (Gate_In); + + case Wire_Id_Table.Table (Asgn_Rec.Id).Kind is + when Wire_Output + | Wire_Signal + | Wire_Variable => + if Drv /= No_Net then + -- Output already assigned + raise Internal_Error; + else + Drv := Inference.Infere (Ctxt, Asgn_Rec.Value, Outport); + + if Get_Id (Gate_Inst) = Id_Isignal + and then Get_Driver (Get_Input (Gate_Inst, 1)) = No_Net + then + -- Mutate Isignal to signal. + New_Sig := Build_Signal + (Ctxt, Get_Name (Gate_Inst), Get_Width (Outport)); + Connect (Get_Input (Get_Parent (New_Sig), 0), Drv); + Redirect_Inputs (Outport, New_Sig); + Wire_Id_Table.Table (Asgn_Rec.Id).Gate := New_Sig; + Free_Instance (Gate_Inst); + else + Connect (Gate_In, Drv); + end if; + end if; + when others => + raise Internal_Error; + end case; + + Asgn := Asgn_Rec.Chain; + end; + end loop; + -- FIXME: free wires. + end Pop_And_Merge_Phi; + + -- Sort the LEN first wires of chain W (linked by Chain) in Id increasing + -- values. The result is assigned to FIRST and the first non-sorted wire + -- (the one after LEN) is assigned to NEXT. The chain headed by FIRST + -- is truncated to LEN elements. + -- Use a merge sort. + procedure Sort_Wires + (Asgn : Assign; Len : Uns32; First : out Assign; Next : out Assign) + is + Left, Right : Assign; + Last : Assign; + El : Assign; + begin + if Len = 0 then + -- Empty chain. + First := No_Assign; + Next := Asgn; + return; + elsif Len = 1 then + -- Chain with one element. + First := Asgn; + Next := Get_Assign_Chain (First); + Set_Assign_Chain (First, No_Assign); + return; + else + -- Divide. + Sort_Wires (Asgn, Len / 2, Left, Right); + Sort_Wires (Right, Len - Len / 2, Right, Next); + + -- Conquer: merge. + First := No_Assign; + Last := No_Assign; + for I in 1 .. Len loop + if Left /= No_Assign + and then (Right = No_Assign + or else Get_Wire_Id (Left) <= Get_Wire_Id (Right)) + then + El := Left; + Left := Get_Assign_Chain (Left); + else + pragma Assert (Right /= No_Assign); + El := Right; + Right := Get_Assign_Chain (Right); + end if; + + -- Append + if First = No_Assign then + First := El; + else + Set_Assign_Chain (Last, El); + end if; + Last := El; + end loop; + Set_Assign_Chain (Last, No_Assign); + end if; + end Sort_Wires; + + function Sort_Phi (P : Phi_Type) return Assign + is + Res, Last : Assign; + begin + Sort_Wires (P.First, P.Nbr, Res, Last); + pragma Assert (Last = No_Assign); + return Res; + end Sort_Phi; + + function Get_Assign_Value (Asgn : Assign) return Net + is + Asgn_Rec : Assign_Record renames Assign_Table.Table (Asgn); + begin + case Wire_Id_Table.Table (Asgn_Rec.Id).Kind is + when Wire_Signal | Wire_Output | Wire_Inout | Wire_Variable => + return Asgn_Rec.Value; + when Wire_Input | Wire_None => + raise Internal_Error; + end case; + end Get_Assign_Value; + + function Get_Current_Value (Wid : Wire_Id) return Net + is + Wid_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid); + begin + case Wid_Rec.Kind is + when Wire_Variable => + if Wid_Rec.Cur_Assign = No_Assign then + return Wid_Rec.Gate; + else + return Assign_Table.Table (Wid_Rec.Cur_Assign).Value; + end if; + when Wire_Signal | Wire_Output | Wire_Inout | Wire_Input => + return Wid_Rec.Gate; + when Wire_None => + raise Internal_Error; + end case; + end Get_Current_Value; + + function Get_Last_Assigned_Value (Wid : Wire_Id) return Net + is + Wid_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid); + begin + if Wid_Rec.Cur_Assign = No_Assign then + return Wid_Rec.Gate; + else + return Get_Assign_Value (Wid_Rec.Cur_Assign); + end if; + end Get_Last_Assigned_Value; + + procedure Merge_Phis (Ctxt : Builders.Context_Acc; + Sel : Net; + T, F : Phi_Type) + is + T_Asgns : Assign; + F_Asgns : Assign; + W : Wire_Id; + Te, Fe : Net; + Res : Net; + begin + T_Asgns := Sort_Phi (T); + F_Asgns := Sort_Phi (F); + + while T_Asgns /= No_Assign or F_Asgns /= No_Assign loop + -- Extract a wire. + if T_Asgns = No_Assign + or else (F_Asgns /= No_Assign + and then Get_Wire_Id (F_Asgns) < Get_Wire_Id (T_Asgns)) + then + W := Get_Wire_Id (F_Asgns); + Te := Get_Last_Assigned_Value (W); + Fe := Get_Assign_Value (F_Asgns); + F_Asgns := Get_Assign_Chain (F_Asgns); + elsif F_Asgns = No_Assign + or else (T_Asgns /= No_Assign + and then Get_Wire_Id (T_Asgns) < Get_Wire_Id (F_Asgns)) + then + W := Get_Wire_Id (T_Asgns); + Te := Get_Assign_Value (T_Asgns); + Fe := Get_Last_Assigned_Value (W); + T_Asgns := Get_Assign_Chain (T_Asgns); + else + pragma Assert (Get_Wire_Id (F_Asgns) = Get_Wire_Id (T_Asgns)); + W := Get_Wire_Id (F_Asgns); + Te := Get_Assign_Value (T_Asgns); + Fe := Get_Assign_Value (F_Asgns); + T_Asgns := Get_Assign_Chain (T_Asgns); + F_Asgns := Get_Assign_Chain (F_Asgns); + end if; + Res := Netlists.Builders.Build_Mux2 (Ctxt, Sel, Fe, Te); + Phi_Assign (W, Res); + end loop; + end Merge_Phis; + + procedure Phi_Insert_Assign (Asgn : Assign) + is + pragma Assert (Asgn /= No_Assign); + Asgn_Rec : Assign_Record renames Assign_Table.Table (Asgn); + pragma Assert (Asgn_Rec.Phi = Current_Phi); + pragma Assert (Asgn_Rec.Chain = No_Assign); + P : Phi_Type renames Phis_Table.Table (Phis_Table.Last); + begin + Asgn_Rec.Chain := P.First; + P.First := Asgn; + P.Nbr := P.Nbr + 1; + end Phi_Insert_Assign; + + procedure Phi_Assign (Dest : Wire_Id; Val : Net) + is + Cur_Asgn : constant Assign := Wire_Id_Table.Table (Dest).Cur_Assign; + begin + if Cur_Asgn = No_Assign + or else Assign_Table.Table (Cur_Asgn).Phi < Current_Phi + then + -- Never assigned, or first assignment in that level + Assign_Table.Append ((Phi => Current_Phi, + Id => Dest, + Prev => Cur_Asgn, + Chain => No_Assign, + Value => Val)); + Wire_Id_Table.Table (Dest).Cur_Assign := Assign_Table.Last; + Phi_Insert_Assign (Assign_Table.Last); + else + -- Overwrite. + -- FIXME: may need to merge in case of partial assignment. + Assign_Table.Table (Cur_Asgn).Value := Val; + end if; + end Phi_Assign; + + function Current_Phi return Phi_Id is + begin + return Phis_Table.Last; + end Current_Phi; +begin + Wire_Id_Table.Append ((Kind => Wire_None, + Mark_Flag => False, + Decl => Source.No_Syn_Src, + Gate => No_Net, + Cur_Assign => No_Assign)); + pragma Assert (Wire_Id_Table.Last = No_Wire_Id); + + Assign_Table.Append ((Phi => No_Phi_Id, + Id => No_Wire_Id, + Prev => No_Assign, + Chain => No_Assign, + Value => No_Net)); + pragma Assert (Assign_Table.Last = No_Assign); + + Phis_Table.Append ((First => No_Assign, + Nbr => 0)); + pragma Assert (Phis_Table.Last = No_Phi_Id); +end Synth.Environment; diff --git a/src/synth/synth-environment.ads b/src/synth/synth-environment.ads new file mode 100644 index 000000000..6b5c4af31 --- /dev/null +++ b/src/synth/synth-environment.ads @@ -0,0 +1,153 @@ +-- Environment definition 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Tables; +with Netlists; use Netlists; +with Netlists.Builders; +with Synth.Source; + +package Synth.Environment is + -- A simple signal/variable is either a bit or a std_ulogic + -- signal/variable, or a bus (bit_vector, std_ulogic_vector, signed, + -- unsigned...). + -- + -- Complex signals/variables (records, arrays) are decomposed to simple + -- signals/variables. + -- + -- Each simple signal/variable is represented by a Wire_Id. Synthesis + -- deals only with these wires or group of them. + type Wire_Id is new Uns32; + No_Wire_Id : constant Wire_Id := 0; + + -- A Wire is either a signal, a variable or a port. We need to know the + -- nature of a wire as the assignment semantic is not the same (a variable + -- assignment overwrite the old value, while a signal assignment is + -- effective at the next cycle). + type Wire_Kind is (Wire_None, + Wire_Signal, Wire_Variable, + Wire_Input, Wire_Output, Wire_Inout); + + type Assign is new Uns32; + No_Assign : constant Assign := 0; + + -- A Wire_Id represents a bit or a vector. + type Wire_Id_Record is record + -- Kind of wire: signal, variable... + -- Set at initialization and cannot be changed. + Kind : Wire_Kind; + + -- Used in various algorithms: a flag on a wire. This flag must be + -- cleared after usage. + Mark_Flag : Boolean; + + -- Source node that created the wire. + Decl : Source.Syn_Src; + + -- The initial net for the wire. + Gate : Net; + + Cur_Assign : Assign; + end record; + + -- The current value of WID. For variables, this is the last assigned + -- value. For signals, this is the initial value. + function Get_Current_Value (Wid : Wire_Id) return Net; + + -- The last assigned value to WID. + function Get_Last_Assigned_Value (Wid : Wire_Id) return Net; + + -- + + type Phi_Id is new Uns32; + No_Phi_Id : constant Phi_Id := 0; + + type Assign_Record is record + -- Target of the assignment. + Id : Wire_Id; + + -- Assignment is the previous phi context. + Prev : Assign; + + -- Corresponding phi context for this wire. + Phi : Phi_Id; + + -- Next wire in the phi context. + Chain : Assign; + + -- Value assigned. + Value : Net; + end record; + + function Get_Wire_Id (W : Assign) return Wire_Id; + function Get_Assign_Chain (Asgn : Assign) return Assign; + function Get_Assign_Value (Asgn : Assign) return Net; + + type Phi_Type is private; + + -- Create a new phi context. + procedure Push_Phi; + + procedure Pop_Phi (Phi : out Phi_Type); + + -- Destroy the current phi context and merge it. Can apply only for the + -- first non-top level phi context. + procedure Pop_And_Merge_Phi (Ctxt : Builders.Context_Acc); + + procedure Merge_Phis (Ctxt : Builders.Context_Acc; + Sel : Net; + T, F : Phi_Type); + + function Sort_Phi (P : Phi_Type) return Assign; + + -- Add a new wire in the phi context. + procedure Phi_Insert_Assign (Asgn : Assign); + + -- In the current phi context, assign VAL to DEST. + procedure Phi_Assign (Dest : Wire_Id; Val : Net); + + -- Get current phi context. + function Current_Phi return Phi_Id; + pragma Inline (Current_Phi); + + package Wire_Id_Table is new Tables + (Table_Component_Type => Wire_Id_Record, + Table_Index_Type => Wire_Id, + Table_Low_Bound => No_Wire_Id, + Table_Initial => 1024); + + package Assign_Table is new Tables + (Table_Component_Type => Assign_Record, + Table_Index_Type => Assign, + Table_Low_Bound => No_Assign, + Table_Initial => 1024); + +private + type Phi_Type is record + First : Assign; + Nbr : Uns32; + end record; + + package Phis_Table is new Tables + (Table_Component_Type => Phi_Type, + Table_Index_Type => Phi_Id, + Table_Low_Bound => No_Phi_Id, + Table_Initial => 16); +end Synth.Environment; diff --git a/src/synth/synth-errors.adb b/src/synth/synth-errors.adb new file mode 100644 index 000000000..4acfe560c --- /dev/null +++ b/src/synth/synth-errors.adb @@ -0,0 +1,36 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package body Synth.Errors is + procedure Error_Msg_Synth (Loc : Location_Type; + Msg : String; + Arg1 : Earg_Type) is + begin + Report_Msg (Msgid_Error, Errorout.Elaboration, + Loc, Msg, (1 => Arg1)); + end Error_Msg_Synth; + + procedure Error_Msg_Synth (Loc : Location_Type; + Msg : String) is + begin + Report_Msg (Msgid_Error, Errorout.Elaboration, + Loc, Msg, (1 .. 0 => <>)); + end Error_Msg_Synth; +end Synth.Errors; diff --git a/src/synth/synth-errors.ads b/src/synth/synth-errors.ads new file mode 100644 index 000000000..ccc48d375 --- /dev/null +++ b/src/synth/synth-errors.ads @@ -0,0 +1,30 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Errorout; use Errorout; + +package Synth.Errors is + procedure Error_Msg_Synth (Loc : Location_Type; + Msg : String; + Arg1 : Earg_Type); + procedure Error_Msg_Synth (Loc : Location_Type; + Msg : String); +end Synth.Errors; diff --git a/src/synth/synth-expr.adb b/src/synth/synth-expr.adb new file mode 100644 index 000000000..009af9cf7 --- /dev/null +++ b/src/synth/synth-expr.adb @@ -0,0 +1,726 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Std_Names; +with Ieee.Std_Logic_1164; +with Std_Package; +with Errorout; use Errorout; +with Execution; +with Grt.Types; use Grt.Types; + +with Synth.Errors; use Synth.Errors; +with Synth.Context; use Synth.Context; +with Synth.Types; use Synth.Types; + +with Netlists; use Netlists; +with Netlists.Gates; use Netlists.Gates; +with Netlists.Builders; use Netlists.Builders; + +package body Synth.Expr is + function Is_Const (Val : Value_Acc) return Boolean is + begin + return Val.Kind = Value_Lit; + end Is_Const; + + function Get_Width (Val : Value_Acc) return Uns32 is + begin + case Val.Kind is + when Value_Lit => + if Is_Bit_Type (Val.Lit_Type) then + return 1; + else + raise Internal_Error; + end if; + when Value_Wire + | Value_Net => + return Get_Width (Get_Net (Val)); + when others => + raise Internal_Error; -- TODO + end case; + end Get_Width; + + procedure To_Logic (Lit : Iir_Value_Literal_Acc; + Val : out Uns32; + Xz : out Uns32) is + begin + case Lit.Kind is + when Iir_Value_B1 => + Xz := 0; + Val := Ghdl_B1'Pos (Lit.B1); + when Iir_Value_E8 => + -- Std_logic. + case Lit.E8 is + when Ieee.Std_Logic_1164.Std_Logic_0_Pos + | Ieee.Std_Logic_1164.Std_Logic_L_Pos => + Val := 0; + Xz := 0; + when Ieee.Std_Logic_1164.Std_Logic_1_Pos + | Ieee.Std_Logic_1164.Std_Logic_H_Pos => + Val := 1; + Xz := 0; + when Ieee.Std_Logic_1164.Std_Logic_U_Pos + | Ieee.Std_Logic_1164.Std_Logic_X_Pos + | Ieee.Std_Logic_1164.Std_Logic_D_Pos => + Val := 0; + Xz := 1; + when Ieee.Std_Logic_1164.Std_Logic_Z_Pos + | Ieee.Std_Logic_1164.Std_Logic_W_Pos => + Val := 1; + Xz := 1; + when others => + -- Only 9 values. + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end To_Logic; + + function Bit_Extract (Val : Value_Acc; Off : Uns32) return Value_Acc is + begin + case Val.Kind is + when Value_Lit => + declare + Lit : constant Iir_Value_Literal_Acc := Val.Lit; + begin + pragma Assert (Lit.Kind = Iir_Value_Array); + pragma Assert (Lit.Bounds.Nbr_Dims = 1); + pragma Assert (Lit.Bounds.D (1).Length >= Iir_Index32 (Off)); + return Create_Value_Lit + (Lit.Val_Array.V (Lit.Val_Array.Len - Iir_Index32 (Off)), + Get_Element_Subtype (Val.Lit_Type)); + end; + when Value_Net + | Value_Wire => + return Create_Value_Net + (Build_Extract_Bit (Build_Context, Get_Net (Val), Off), + No_Range); + when others => + raise Internal_Error; + end case; + end Bit_Extract; + + function Synth_Uresize (Val : Value_Acc; W : Width) return Net + is + N : constant Net := Get_Net (Val); + Wn : constant Width := Get_Width (N); + begin + if Wn > W then + return Build_Trunc (Build_Context, Id_Utrunc, N, W); + elsif Wn < W then + return Build_Extend (Build_Context, Id_Uextend, N, W); + else + return N; + end if; + end Synth_Uresize; + + procedure Fill_Array_Aggregate + (Syn_Inst : Synth_Instance_Acc; + Aggr : Iir; + Res : Value_Acc; + Dim : Iir_Index32; + Orig : Iir_Index32; + Stride : Iir_Index32) + is + Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); + Value : Iir; + Assoc : Iir; + Pos : Iir_Index32; + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Value_Acc; + begin + if Dim = Res.Bounds.Nbr_Dims then + Val := Synth_Expression_With_Type + (Syn_Inst, Value, Get_Element_Subtype (Get_Type (Aggr))); + Res.Arr.V (Orig + Stride * Pos) := Val; + else + Error_Msg_Synth (+Assoc, "multi-dim aggregate not handled"); + end if; + end Set_Elem; + begin + Assoc := Get_Association_Choices_Chain (Aggr); + Pos := 0; + while Is_Valid (Assoc) loop + Value := Get_Associated_Expr (Assoc); + loop + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if Pos >= Bound.Length then + Error_Msg_Synth (+Assoc, "element out of array bound"); + else + Set_Elem (Pos); + end if; + Pos := Pos + 1; + when others => + Error_Msg_Synth + (+Assoc, "unhandled association form"); + end case; + Assoc := Get_Chain (Assoc); + exit when Is_Null (Assoc); + exit when not Get_Same_Alternative_Flag (Assoc); + end loop; + end loop; + end Fill_Array_Aggregate; + + type Net_Array is array (Iir_Index32 range <>) of Net; + type Net_Array_Acc is access Net_Array; + procedure Free_Net_Array is new Ada.Unchecked_Deallocation + (Net_Array, Net_Array_Acc); + + -- Convert the one-dimension VAL to a net. + function Vectorize_Array (Val : Value_Acc) return Value_Acc + is + Arr : Net_Array_Acc; + Len : Iir_Index32; + Idx, New_Idx : Iir_Index32; + Res : Value_Acc; + begin + Len := Val.Arr.Len; + + -- Dynamically allocate ARR to handle large arrays. + Arr := new Net_Array (1 .. Len); + for I in Arr'Range loop + Arr (I) := Get_Net (Val.Arr.V (I)); + end loop; + + while Len > 1 loop + Idx := 1; + New_Idx := 0; + while Idx <= Len loop + -- Gather at most 4 nets. + New_Idx := New_Idx + 1; + + if Idx = Len then + Arr (New_Idx) := Arr (Idx); + Idx := Idx + 1; + elsif Idx + 1 = Len then + Arr (New_Idx) := Build_Concat2 + (Build_Context, Arr (Idx), Arr (Idx + 1)); + Idx := Idx + 2; + elsif Idx + 2 = Len then + Arr (New_Idx) := Build_Concat3 + (Build_Context, Arr (Idx), Arr (Idx + 1), Arr (Idx + 2)); + Idx := Idx + 3; + else + Arr (New_Idx) := Build_Concat4 + (Build_Context, + Arr (Idx), Arr (Idx + 1), Arr (Idx + 2), Arr (Idx + 3)); + Idx := Idx + 4; + end if; + end loop; + Len := New_Idx; + end loop; + + Res := Create_Value_Net (Arr (1), Bounds_To_Range (Val.Bounds.D (1))); + + Free_Net_Array (Arr); + + return Res; + end Vectorize_Array; + + function Synth_Aggregate (Syn_Inst : Synth_Instance_Acc; + Aggr : Iir; + Aggr_Type : Iir) return Value_Acc is + begin + case Get_Kind (Aggr_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Bnd : Iir_Value_Literal_Acc; + Res : Value_Acc; + begin + -- Create bounds. + Bnd := Execution.Create_Array_Bounds_From_Type + (Syn_Inst.Sim, Aggr_Type, False); + -- Allocate result + Res := Create_Array_Value (Bnd.Bounds); + Create_Array_Data (Res); + Fill_Array_Aggregate + (Syn_Inst, Aggr, Res, + 1, 1, Res.Arr.Len / Res.Bounds.D (1).Length); + if Is_Vector_Type (Aggr_Type) then + -- Vectorize + Res := Vectorize_Array (Res); + end if; + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + raise Internal_Error; + when others => + Error_Kind ("synth_aggregate", Aggr_Type); + end case; + end Synth_Aggregate; + + function Synth_Bit_Eq_Const (Cst : Value_Acc; Expr : Value_Acc; Loc : Iir) + return Value_Acc + is + pragma Unreferenced (Loc); + Val : Uns32; + Xz : Uns32; + begin + To_Logic (Cst.Lit, Val, Xz); + if Xz /= 0 then + return Create_Value_Net + (Build_Const_UL32 (Build_Context, 0, 1, 1), No_Range); + elsif Val = 1 then + return Expr; + else + pragma Assert (Val = 0); + return Create_Value_Net + (Build_Monadic (Build_Context, Id_Not, Get_Net (Expr)), No_Range); + end if; + end Synth_Bit_Eq_Const; + + function Extract_Range (Val : Value_Acc) return Value_Range_Acc is + begin + case Val.Kind is + when Value_Net => + return Val.N_Range; + when Value_Wire => + return Val.W_Range; + when others => + raise Internal_Error; + end case; + end Extract_Range; + + -- Create the result range of an operator. According to the ieee standard, + -- the range is LEN-1 downto 0. + function Create_Res_Range (Prev : Value_Acc; N : Net) + return Value_Range_Acc + is + Res : Value_Range_Acc; + Wd : Width; + begin + case Prev.Kind is + when Value_Net + | Value_Wire => + Res := Extract_Range (Prev); + when Value_Lit => + Res := No_Range; + when others => + raise Internal_Error; + end case; + + if Res /= No_Range + and then Res.Dir = Iir_Downto + and then Res.Right = 0 + then + -- Normalized range + return Res; + end if; + + Wd := Get_Width (N); + return Create_Range_Value ((Iir_Downto, Wd, Int32 (Wd - 1), 0)); + end Create_Res_Range; + + function Synth_Dyadic_Operation (Def : Iir_Predefined_Functions; + Left : Value_Acc; + Right : Value_Acc; + Loc : Iir) return Value_Acc + is + function Synth_Bit_Dyadic (Id : Dyadic_Module_Id) return Value_Acc is + begin + return Create_Value_Net + (Build_Dyadic (Build_Context, Id, Get_Net (Left), Get_Net (Right)), + No_Range); + end Synth_Bit_Dyadic; + + -- function Synth_Vec_Dyadic (Id : Dyadic_Module_Id) return Value_Acc + -- is + -- L : constant Net := Get_Net (Left); + -- begin + -- return Create_Value_Net + -- (Build_Dyadic (Build_Context, Id, L, Get_Net (Right)), + -- Create_Res_Range (Left, L)); + -- end Synth_Vec_Dyadic; + begin + case Def is + when Iir_Predefined_Error => + return null; + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And + | Iir_Predefined_Ieee_1164_Scalar_And => + return Synth_Bit_Dyadic (Id_And); + when Iir_Predefined_Bit_Xor + | Iir_Predefined_Ieee_1164_Scalar_Xor => + return Synth_Bit_Dyadic (Id_Xor); + when Iir_Predefined_Bit_Or + | Iir_Predefined_Ieee_1164_Scalar_Or => + return Synth_Bit_Dyadic (Id_Or); + when Iir_Predefined_Enum_Equality => + if Get_Width (Left) = 1 then + if Is_Const (Left) then + return Synth_Bit_Eq_Const (Left, Right, Loc); + elsif Is_Const (Right) then + return Synth_Bit_Eq_Const (Right, Left, Loc); + end if; + end if; + -- TODO + Error_Msg_Synth (+Loc, "unsupported enum equality"); + raise Internal_Error; + when Iir_Predefined_Ieee_Numeric_Std_Add_Uns_Nat => + -- "+" (Unsigned, Natural) + declare + L : constant Net := Get_Net (Left); + begin + return Create_Value_Net + (Build_Dyadic (Build_Context, Id_Add, + L, + Synth_Uresize (Right, Get_Width (Left))), + Create_Res_Range (Left, L)); + end; + when Iir_Predefined_Ieee_Numeric_Std_Eq_Uns_Nat => + -- "=" (Unsigned, Natural) + return Create_Value_Net + (Build_Compare (Build_Context, Id_Eq, + Get_Net (Left), + Synth_Uresize (Right, Get_Width (Left))), + No_Range); + when others => + Error_Msg_Synth + (+Loc, + "unhandled dyadic: " & Iir_Predefined_Functions'Image (Def)); + raise Internal_Error; + end case; + end Synth_Dyadic_Operation; + + function Synth_Monadic_Operation (Def : Iir_Predefined_Functions; + Operand : Value_Acc; + Loc : Iir) return Value_Acc + is + function Synth_Bit_Monadic (Id : Monadic_Module_Id) return Value_Acc is + begin + return Create_Value_Net + (Build_Monadic (Build_Context, Id, Get_Net (Operand)), + No_Range); + end Synth_Bit_Monadic; + begin + case Def is + when Iir_Predefined_Error => + return null; + when Iir_Predefined_Ieee_1164_Scalar_Not => + return Synth_Bit_Monadic (Id_Not); + when others => + Error_Msg_Synth + (+Loc, + "unhandled monadic: " & Iir_Predefined_Functions'Image (Def)); + raise Internal_Error; + end case; + end Synth_Monadic_Operation; + + function Synth_Name (Syn_Inst : Synth_Instance_Acc; Name : Iir) + return Value_Acc is + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name => + return Synth_Name (Syn_Inst, Get_Named_Entity (Name)); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration => + return Get_Value (Syn_Inst, Name); + when others => + Error_Kind ("synth_name", Name); + end case; + end Synth_Name; + + function In_Range (Rng : Value_Range_Acc; V : Int32) return Boolean is + begin + case Rng.Dir is + when Iir_To => + return V >= Rng.Left and then V <= Rng.Right; + when Iir_Downto => + return V <= Rng.Left and then V >= Rng.Right; + end case; + end In_Range; + + function Synth_Indexed_Name (Syn_Inst : Synth_Instance_Acc; Name : Iir) + return Value_Acc + is + Pfx : constant Value_Acc := + Synth_Expression (Syn_Inst, Get_Prefix (Name)); + Indexes : constant Iir_List := Get_Index_List (Name); + Idx_Val : constant Value_Acc := + Synth_Expression (Syn_Inst, Get_Nth_Element (Indexes, 0)); + Rng : Value_Range_Acc; + Idx : Int32; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + Error_Msg_Synth (+Name, "multi-dim arrays not supported"); + return null; + end if; + + if Idx_Val.Kind /= Value_Lit + or else Idx_Val.Lit.Kind /= Iir_Value_I64 + then + Error_Msg_Synth (+Name, "non constant integer index not supported"); + return null; + end if; + + Rng := Extract_Range (Pfx); + Idx := Int32 (Idx_Val.Lit.I64); + if not In_Range (Rng, Idx) then + Error_Msg_Synth (+Name, "index not within bounds"); + return null; + end if; + + case Rng.Dir is + when Iir_To => + return Bit_Extract (Pfx, Uns32 (Rng.Right - Idx)); + when Iir_Downto => + return Bit_Extract (Pfx, Uns32 (Idx - Rng.Left)); + end case; + end Synth_Indexed_Name; + + -- Match: clk_signal_name'event + -- and return clk_signal_name. + function Extract_Event_Expr_Prefix (Expr : Iir) return Iir is + begin + if Get_Kind (Expr) = Iir_Kind_Event_Attribute then + return Get_Prefix (Expr); + else + return Null_Iir; + end if; + end Extract_Event_Expr_Prefix; + + function Is_Same_Node (Left, Right : Iir) return Boolean is + begin + if Get_Kind (Left) /= Get_Kind (Right) then + return False; + end if; + case Get_Kind (Left) is + when Iir_Kind_Simple_Name => + return Get_Named_Entity (Left) = Get_Named_Entity (Right); + when others => + Error_Kind ("is_same_node", Left); + end case; + end Is_Same_Node; + + -- Match: clk_signal_name = '1' | clk_signal_name = '0' + function Extract_Clock_Level + (Syn_Inst : Synth_Instance_Acc; Expr : Iir; Prefix : Iir) return Net + is + Clk : Net; + Imp : Iir; + Left, Right : Iir; + Lit : Iir; + Posedge : Boolean; + begin + Clk := Get_Net (Synth_Name (Syn_Inst, Prefix)); + if Get_Kind (Expr) /= Iir_Kind_Equality_Operator then + Error_Msg_Synth (+Expr, "ill-formed clock-level, '=' expected"); + return Build_Edge (Build_Context, True, Clk); + end if; + Imp := Get_Implementation (Expr); + if Get_Implicit_Definition (Imp) /= Iir_Predefined_Enum_Equality then + Error_Msg_Synth (+Expr, "ill-formed clock-level, '=' expected"); + return Build_Edge (Build_Context, True, Clk); + end if; + Left := Get_Left (Expr); + Right := Get_Right (Expr); + if Get_Kind (Right) /= Iir_Kind_Character_Literal then + Error_Msg_Synth + (+Expr, "ill-formed clock-level, '0' or '1' expected"); + return Build_Edge (Build_Context, True, Clk); + end if; + Lit := Get_Named_Entity (Right); + if Lit = Std_Package.Bit_0 + or else Lit = Ieee.Std_Logic_1164.Std_Ulogic_0 + then + Posedge := False; + elsif Lit = Std_Package.Bit_1 + or else Lit = Ieee.Std_Logic_1164.Std_Ulogic_1 + then + Posedge := True; + else + Error_Msg_Synth + (+Lit, "ill-formed clock-level, '0' or '1' expected"); + Posedge := True; + end if; + if not Is_Same_Node (Prefix, Left) then + Error_Msg_Synth + (+Left, "clock signal name doesn't match"); + end if; + return Build_Edge (Build_Context, Posedge, Clk); + end Extract_Clock_Level; + + function Synth_Clock_Edge (Syn_Inst : Synth_Instance_Acc; Expr : Iir) + return Value_Acc + is + pragma Assert (Get_Kind (Expr) = Iir_Kind_And_Operator); + Left : constant Iir := Get_Left (Expr); + Right : constant Iir := Get_Right (Expr); + Prefix : Iir; + begin + -- Try with left. + Prefix := Extract_Event_Expr_Prefix (Left); + if Is_Valid (Prefix) then + return Create_Value_Net + (Extract_Clock_Level (Syn_Inst, Right, Prefix), No_Range); + end if; + + -- Try with right. + Prefix := Extract_Event_Expr_Prefix (Right); + if Is_Valid (Prefix) then + return Create_Value_Net + (Extract_Clock_Level (Syn_Inst, Left, Prefix), No_Range); + end if; + + return null; + end Synth_Clock_Edge; + + function Synth_Type_Conversion (Syn_Inst : Synth_Instance_Acc; Conv : Iir) + return Value_Acc + is + Expr : constant Iir := Get_Expression (Conv); + Val : Value_Acc; + begin + Val := Synth_Expression (Syn_Inst, Expr); + if Is_Vector_Type (Get_Type (Conv)) then + return Val; + else + Error_Msg_Synth (+Conv, "unhandled type conversion"); + return Val; + end if; + end Synth_Type_Conversion; + + function Synth_Assoc_In (Syn_Inst : Synth_Instance_Acc; + Assoc : Iir) return Value_Acc is + begin + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then + return Synth_Expression (Syn_Inst, Get_Actual (Assoc)); + else + Error_Kind ("synth_assoc_in", Assoc); + end if; + end Synth_Assoc_In; + + procedure Error_Unknown_Operator (Imp : Iir; Loc : Iir) is + begin + if Get_Kind (Get_Parent (Imp)) = Iir_Kind_Package_Declaration + and then (Get_Identifier + (Get_Library + (Get_Design_File (Get_Design_Unit (Get_Parent (Imp))))) + = Std_Names.Name_Ieee) + then + Error_Msg_Synth (+Loc, "unhandled predefined IEEE operator %i", +Imp); + Error_Msg_Synth (+Imp, " declared here"); + else + Error_Msg_Synth (+Loc, "user defined operator %i not handled", +Imp); + end if; + end Error_Unknown_Operator; + + function Synth_Expression_With_Type + (Syn_Inst : Synth_Instance_Acc; Expr : Iir; Expr_Type : Iir) + return Value_Acc is + begin + case Get_Kind (Expr) is + when Iir_Kinds_Dyadic_Operator => + declare + Imp : constant Iir := Get_Implementation (Expr); + Def : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Left : Value_Acc; + Right : Value_Acc; + begin + -- Match clock-edge + if Def = Iir_Predefined_Boolean_And then + Left := Synth_Clock_Edge (Syn_Inst, Expr); + if Left /= null then + return Left; + end if; + end if; + + Left := Synth_Expression (Syn_Inst, Get_Left (Expr)); + Right := Synth_Expression (Syn_Inst, Get_Right (Expr)); + if Def in Iir_Predefined_Implicit + or else Def in Iir_Predefined_IEEE_Explicit + then + return Synth_Dyadic_Operation (Def, Left, Right, Expr); + else + Error_Unknown_Operator (Imp, Expr); + return Left; + end if; + end; + when Iir_Kinds_Monadic_Operator => + declare + Imp : constant Iir := Get_Implementation (Expr); + Def : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Operand : Value_Acc; + begin + Operand := Synth_Expression (Syn_Inst, Get_Operand (Expr)); + if Def in Iir_Predefined_Implicit + or else Def in Iir_Predefined_IEEE_Explicit + then + return Synth_Monadic_Operation (Def, Operand, Expr); + else + Error_Unknown_Operator (Imp, Expr); + return Operand; + end if; + end; + when Iir_Kind_Simple_Name => + return Synth_Name (Syn_Inst, Expr); + when Iir_Kind_Indexed_Name => + return Synth_Indexed_Name (Syn_Inst, Expr); + when Iir_Kind_Character_Literal + | Iir_Kind_Integer_Literal + | Iir_Kind_String_Literal8 => + return Create_Value_Lit + (Execution.Execute_Expression (Syn_Inst.Sim, Expr), + Get_Base_Type (Get_Type (Expr))); + when Iir_Kind_Type_Conversion => + return Synth_Type_Conversion (Syn_Inst, Expr); + when Iir_Kind_Qualified_Expression => + return Synth_Expression_With_Type + (Syn_Inst, Get_Expression (Expr), Get_Type (Expr)); + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := Get_Implementation (Expr); + Clk : Net; + begin + if Imp = Ieee.Std_Logic_1164.Rising_Edge then + Clk := Get_Net + (Synth_Assoc_In + (Syn_Inst, Get_Parameter_Association_Chain (Expr))); + return Create_Value_Net + (Build_Edge (Build_Context, True, Clk), No_Range); + end if; + Error_Msg_Synth + (+Expr, "user function call to %i is not handled", +Imp); + end; + when Iir_Kind_Aggregate => + return Synth_Aggregate (Syn_Inst, Expr, Expr_Type); + when others => + Error_Kind ("synth_expression", Expr); + end case; + return null; + end Synth_Expression_With_Type; + + function Synth_Expression (Syn_Inst : Synth_Instance_Acc; Expr : Iir) + return Value_Acc is + begin + return Synth_Expression_With_Type (Syn_Inst, Expr, Get_Type (Expr)); + end Synth_Expression; + +end Synth.Expr; diff --git a/src/synth/synth-expr.ads b/src/synth/synth-expr.ads new file mode 100644 index 000000000..3180b3afd --- /dev/null +++ b/src/synth/synth-expr.ads @@ -0,0 +1,42 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Iir_Values; use Iir_Values; +with Synth.Values; use Synth.Values; +with Iirs; use Iirs; + +package Synth.Expr is + function Is_Const (Val : Value_Acc) return Boolean; + function Get_Width (Val : Value_Acc) return Uns32; + + procedure To_Logic (Lit : Iir_Value_Literal_Acc; + Val : out Uns32; + Xz : out Uns32); + + function Bit_Extract (Val : Value_Acc; Off : Uns32) return Value_Acc; + + function Synth_Expression_With_Type + (Syn_Inst : Synth_Instance_Acc; Expr : Iir; Expr_Type : Iir) + return Value_Acc; + + function Synth_Expression (Syn_Inst : Synth_Instance_Acc; Expr : Iir) + return Value_Acc; +end Synth.Expr; diff --git a/src/synth/synth-inference.adb b/src/synth/synth-inference.adb new file mode 100644 index 000000000..68f10c638 --- /dev/null +++ b/src/synth/synth-inference.adb @@ -0,0 +1,235 @@ +-- Inference 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists.Utils; use Netlists.Utils; +with Netlists.Gates; use Netlists.Gates; +with Netlists.Gates_Ports; use Netlists.Gates_Ports; +with Types; use Types; + +package body Synth.Inference is + type Mux_Info_Type is record + Mux : Instance; + Chain : Port_Nbr; + end record; + + type Mux_Info_Arr is array (Natural range <>) of Mux_Info_Type; + + procedure Find_Longest_Loop + (Val : Net; Prev_Val : Net; Res : out Instance; Dist : out Integer) + is + Inst : constant Instance := Get_Parent (Val); + begin + if Get_Id (Inst) = Id_Mux2 then + declare + Res0, Res1 : Instance; + Dist0, Dist1 : Integer; + begin + Find_Longest_Loop + (Get_Driver (Get_Mux2_I0 (Inst)), Prev_Val, Res0, Dist0); + Find_Longest_Loop + (Get_Driver (Get_Mux2_I1 (Inst)), Prev_Val, Res1, Dist1); + -- Input1 has an higher priority than input0 in case the selector + -- is a clock. + -- FIXME: improve algorithm. + if Dist1 > Dist0 then + Dist := Dist1 + 1; + if Dist1 > 0 then + Res := Res1; + else + Res := Inst; + end if; + elsif Dist0 >= 0 then + Dist := Dist0 + 1; + if Dist0 > 0 then + Res := Res0; + else + Res := Inst; + end if; + else + pragma Assert (Dist1 < 0 and Dist0 < 0); + Res := No_Instance; + Dist := -1; + end if; + end; + elsif Val = Prev_Val then + Res := No_Instance; + Dist := 0; + else + Res := No_Instance; + Dist := -1; + end if; + end Find_Longest_Loop; + + -- Walk the And-net N, and extract clock (posedge/negedge) if found. + -- ENABLE is N without the clock. + procedure Extract_Clock (N : Net; Clk : out Net; Enable : out Net) + is + Inst : constant Instance := Get_Net_Parent (N); + begin + Clk := No_Net; + Enable := No_Net; + + case Get_Id (Inst) is + when Edge_Module_Id => + Clk := N; + when Id_And => + -- Assume the condition is canonicalized, ie of the form: + -- CLK and EXPR. + -- FIXME: do it! + declare + I0 : constant Input := Get_Input (Inst, 0); + I1 : Input; + Drv : Net; + begin + Drv := Get_Driver (I0); + if Get_Id (Get_Net_Parent (Drv)) in Edge_Module_Id then + Disconnect (I0); + Clk := Drv; + I1 := Get_Input (Inst, 1); + Enable := Get_Driver (I1); + Disconnect (I1); + Free_Instance (Inst); + end if; + end; + when others => + null; + end case; + end Extract_Clock; + + function Infere (Ctxt : Context_Acc; Val : Net; Prev_Val : Net) return Net + is + pragma Assert (Val /= No_Net); + pragma Assert (Prev_Val /= No_Net); + Last_Mux : Instance; + Len : Integer; + begin + Find_Longest_Loop (Val, Prev_Val, Last_Mux, Len); + if Len < 0 then + -- No logical loop + return Val; + elsif Len = 0 then + -- Self assignment. + return Val; + end if; + + -- Create the array of mux till the last one. + -- Find the one with clock edge. + -- If none -> latch (not yet supported) + -- If found -> previous mux2 (if any) are either asynch set/reset or + -- enable. + declare + Mux_Info : Mux_Info_Arr (1 .. Len); + begin + -- Fill array. + declare + Mux : Instance; + O : Net; + begin + Mux := Last_Mux; + for I in reverse Mux_Info'Range loop + pragma Assert (Get_Id (Mux) = Id_Mux2); + Mux_Info (I) := (Mux => Mux, Chain => 0); + exit when I = Mux_Info'First; + O := Get_Output (Mux, 0); + pragma Assert (Has_One_Connection (O)); + Mux := Get_Parent (Get_First_Sink (O)); + end loop; + end; + + -- Classify. + for I in Mux_Info'Range loop + declare + Mi : Mux_Info_Type renames Mux_Info (I); + Sel : constant Input := Get_Mux2_Sel (Mi.Mux); + I0 : constant Input := Get_Mux2_I0 (Mi.Mux); + I1 : constant Input := Get_Mux2_I1 (Mi.Mux); + Data : Net; + Clk : Net; + Enable : Net; + Res : Net; + Sig : Instance; + Init : Net; + Init_Input : Input; + begin + Extract_Clock (Get_Driver (Sel), Clk, Enable); + if Clk = No_Net then + -- Enable or async reset/set. + if Get_Driver (I0) = Prev_Val then + -- Enable + raise Internal_Error; + elsif Get_Driver (I1) = Prev_Val then + -- /Enable + raise Internal_Error; + else + -- Set or reset. + raise Internal_Error; + end if; + else + -- Create and return the DFF. + Disconnect (Sel); + if Get_Driver (I0) /= Prev_Val then + -- There must be no 'else' part for clock expression. + raise Internal_Error; + end if; + -- Don't try to free driver of I0 as this is Prev_Val. + Disconnect (I0); + Data := Get_Driver (I1); + -- Don't try to free driver of I1 as it is reconnected. + Disconnect (I1); + if Enable /= No_Net then + Data := Build_Mux2 (Ctxt, Enable, Prev_Val, Data); + end if; + + -- If the signal declaration has an initial value, move it + -- to the dff. + Sig := Get_Parent (Prev_Val); + if Get_Id (Get_Module (Sig)) = Id_Isignal then + Init_Input := Get_Input (Sig, 1); + Init := Get_Driver (Init_Input); + Disconnect (Init_Input); + else + Init := No_Net; + end if; + + if Init /= No_Net then + Res := Build_Idff (Ctxt, Clk, D => Data, Init => Init); + else + Res := Build_Dff (Ctxt, Clk, D => Data); + end if; + + -- The output of the mux may be read later in the process, + -- like this: + -- if clk'event and clk = '1' then + -- d := i + 1; + -- end if; + -- d1 := d + 1; + -- So connections to the mux output are redirected to dff + -- output. + Redirect_Inputs (Get_Output (Mi.Mux, 0), Res); + + Free_Instance (Mi.Mux); + return Res; + end if; + end; + end loop; + end; + raise Internal_Error; + end Infere; +end Synth.Inference; diff --git a/src/synth/synth-inference.ads b/src/synth/synth-inference.ads new file mode 100644 index 000000000..5777e04e4 --- /dev/null +++ b/src/synth/synth-inference.ads @@ -0,0 +1,29 @@ +-- Inference 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists; use Netlists; +with Netlists.Builders; use Netlists.Builders; + +package Synth.Inference is + -- To be called when there is an assignment to a signal/output of VAL and + -- the previous value is PREV_VAL (an Id_Signal or Id_Output). + -- If there is a loop, infere a dff or a latch or emit an error. + function Infere (Ctxt : Context_Acc; Val : Net; Prev_Val : Net) return Net; +end Synth.Inference; diff --git a/src/synth/synth-source.ads b/src/synth/synth-source.ads new file mode 100644 index 000000000..d6504d268 --- /dev/null +++ b/src/synth/synth-source.ads @@ -0,0 +1,26 @@ +-- Source/origin of 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Iirs; use Iirs; + +package Synth.Source is + subtype Syn_Src is Iir; + No_Syn_Src : constant Syn_Src := Null_Iir; +end Synth.Source; diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-stmts.adb new file mode 100644 index 000000000..5594a6e4a --- /dev/null +++ b/src/synth/synth-stmts.adb @@ -0,0 +1,826 @@ +-- Statements 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Unchecked_Deallocation; + +with Types; use Types; +with Algos; +with Areapools; +with Errorout; use Errorout; + +with Sem_Expr; +with Iirs_Utils; use Iirs_Utils; +with Ieee.Std_Logic_1164; +with Evaluation; + +with Synth.Types; use Synth.Types; +with Synth.Errors; use Synth.Errors; +with Synth.Decls; use Synth.Decls; +with Synth.Expr; use Synth.Expr; +with Synth.Context; use Synth.Context; +with Synth.Environment; use Synth.Environment; + +with Iir_Values; use Iir_Values; +with Annotations; +with Execution; +with Elaboration; use Elaboration; + +with Netlists; use Netlists; +with Netlists.Builders; use Netlists.Builders; + +package body Synth.Stmts is + function Synth_Waveform (Syn_Inst : Synth_Instance_Acc; + Wf : Iir; + Targ_Type : Iir) return Value_Acc + is + begin + if Get_Kind (Wf) = Iir_Kind_Unaffected_Waveform then + -- TODO + raise Internal_Error; + end if; + if Get_Chain (Wf) /= Null_Iir then + -- Warning. + null; + end if; + if Get_Time (Wf) /= Null_Iir then + -- Warning + null; + end if; + return Synth_Expression_With_Type + (Syn_Inst, Get_We_Value (Wf), Targ_Type); + end Synth_Waveform; + + procedure Synth_Assign (Dest : Value_Acc; Val : Value_Acc) + is + begin + case Dest.Kind is + when Value_Wire => + Phi_Assign (Dest.W, Get_Net (Val)); + when others => + raise Internal_Error; + end case; + end Synth_Assign; + + procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc; + Target : Iir; + Val : Value_Acc); + + procedure Synth_Assignment_Aggregate (Syn_Inst : Synth_Instance_Acc; + Target : Iir; + Val : Value_Acc) + is + Targ_Type : constant Iir := Get_Type (Target); + Choice : Iir; + Assoc : Iir; + Pos : Uns32; + begin + if Is_Vector_Type (Targ_Type) then + Choice := Get_Association_Choices_Chain (Target); + Pos := Get_Width (Syn_Inst, Targ_Type); + while Is_Valid (Choice) loop + Assoc := Get_Associated_Expr (Choice); + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_None => + Pos := Pos - 1; + Synth_Assignment (Syn_Inst, Assoc, Bit_Extract (Val, Pos)); + when others => + Error_Kind ("synth_assignment_aggregate", Choice); + end case; + Choice := Get_Chain (Choice); + end loop; + else + raise Internal_Error; + end if; + end Synth_Assignment_Aggregate; + + procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc; + Target : Iir; + Val : Value_Acc) is + begin + case Get_Kind (Target) is + when Iir_Kind_Simple_Name => + Synth_Assignment (Syn_Inst, Get_Named_Entity (Target), Val); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration => + Synth_Assign (Get_Value (Syn_Inst, Target), Val); + when Iir_Kind_Aggregate => + Synth_Assignment_Aggregate (Syn_Inst, Target, Val); + when others => + Error_Kind ("synth_assignment", Target); + end case; + end Synth_Assignment; + + -- Concurrent or sequential simple signal assignment + procedure Synth_Simple_Signal_Assignment + (Syn_Inst : Synth_Instance_Acc; Stmt : Iir) + is + Target : constant Iir := Get_Target (Stmt); + Val : Value_Acc; + begin + Val := Synth_Waveform + (Syn_Inst, Get_Waveform_Chain (Stmt), Get_Type (Target)); + Synth_Assignment (Syn_Inst, Target, Val); + end Synth_Simple_Signal_Assignment; + + procedure Synth_Variable_Assignment + (Syn_Inst : Synth_Instance_Acc; Stmt : Iir) + is + Target : constant Iir := Get_Target (Stmt); + Val : Value_Acc; + begin + Val := Synth_Expression_With_Type + (Syn_Inst, Get_Expression (Stmt), Get_Type (Target)); + Synth_Assignment (Syn_Inst, Target, Val); + end Synth_Variable_Assignment; + + procedure Synth_Sequential_Statements + (Syn_Inst : Synth_Instance_Acc; Stmts : Iir); + + procedure Synth_If_Statement + (Syn_Inst : Synth_Instance_Acc; Stmt : Iir) + is + Cond : constant Iir := Get_Condition (Stmt); + Els : constant Iir := Get_Else_Clause (Stmt); + Cond_Val : Value_Acc; + Phi_True : Phi_Type; + Phi_False : Phi_Type; + begin + Cond_Val := Synth_Expression (Syn_Inst, Cond); + if Is_Const (Cond_Val) then + -- TODO + raise Internal_Error; + else + Push_Phi; + Synth_Sequential_Statements + (Syn_Inst, Get_Sequential_Statement_Chain (Stmt)); + Pop_Phi (Phi_True); + + Push_Phi; + if Is_Valid (Els) then + if Is_Null (Get_Condition (Els)) then + -- Final else part. + Synth_Sequential_Statements + (Syn_Inst, Get_Sequential_Statement_Chain (Els)); + else + -- Elsif. Handled as a nested if. + Synth_If_Statement (Syn_Inst, Els); + end if; + end if; + Pop_Phi (Phi_False); + + Merge_Phis (Build_Context, Get_Net (Cond_Val), Phi_True, Phi_False); + end if; + end Synth_If_Statement; + + procedure Convert_To_Uns64 (Expr : Iir; Val : out Uns64; Dc : out Uns64) + is + El_Type : constant Iir := + Get_Base_Type (Get_Element_Subtype (Get_Type (Expr))); + begin + if El_Type = Ieee.Std_Logic_1164.Std_Ulogic_Type then + declare + use Evaluation.String_Utils; + + Info : Str_Info; + begin + Info := Get_Info (Expr); + if Info.Len > 64 then + raise Internal_Error; + end if; + Val := 0; + Dc := 0; + for I in 0 .. Info.Len - 1 loop + Val := Shift_Left (Val, 1); + Dc := Shift_Left (Dc, 1); + case Get_Pos (Info, I) is + when Ieee.Std_Logic_1164.Std_Logic_0_Pos => + Val := Val or 0; + when Ieee.Std_Logic_1164.Std_Logic_1_Pos => + Val := Val or 1; + when Ieee.Std_Logic_1164.Std_Logic_U_Pos + | Ieee.Std_Logic_1164.Std_Logic_X_Pos + | Ieee.Std_Logic_1164.Std_Logic_Z_Pos + | Ieee.Std_Logic_1164.Std_Logic_W_Pos + | Ieee.Std_Logic_1164.Std_Logic_D_Pos + | Ieee.Std_Logic_1164.Std_Logic_L_Pos + | Ieee.Std_Logic_1164.Std_Logic_H_Pos => + Dc := Dc or 1; + when others => + raise Internal_Error; + end case; + end loop; + end; + else + raise Internal_Error; + end if; + end Convert_To_Uns64; + + type Alternative_Index is new Int32; + + type Choice_Data_Type is record + -- Value of the choice + Val : Uns64; + + -- Corresponding alternative + Alt : Alternative_Index; + end record; + + type Choice_Data_Array is array (Natural range <>) of Choice_Data_Type; + type Choice_Data_Array_Acc is access Choice_Data_Array; + procedure Free_Choice_Data_Array is new Ada.Unchecked_Deallocation + (Choice_Data_Array, Choice_Data_Array_Acc); + + type Alternative_Data_Type is record + Asgns : Assign; + Val : Net; + end record; + type Alternative_Data_Array is + array (Alternative_Index range <>) of Alternative_Data_Type; + type Alternative_Data_Acc is access Alternative_Data_Array; + procedure Free_Alternative_Data_Array is new Ada.Unchecked_Deallocation + (Alternative_Data_Array, Alternative_Data_Acc); + + type Wire_Id_Array is array (Natural range <>) of Wire_Id; + type Wire_Id_Array_Acc is access Wire_Id_Array; + procedure Free_Wire_Id_Array is new Ada.Unchecked_Deallocation + (Wire_Id_Array, Wire_Id_Array_Acc); + + procedure Sort_Wire_Id_Array (Arr : in out Wire_Id_Array) + is + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Arr (Op1) < Arr (Op2); + end Lt; + + procedure Swap (From : Natural; To : Natural) + is + T : Wire_Id; + begin + T := Arr (From); + Arr (From) := Arr (To); + Arr (To) := T; + end Swap; + + procedure Wid_Heap_Sort is new Algos.Heap_Sort (Lt => Lt, Swap => Swap); + begin + Wid_Heap_Sort (Arr'Length); + end Sort_Wire_Id_Array; + + function Count_Wires_In_Alternatives (Alts : Alternative_Data_Array) + return Natural + is + Res : Natural; + Asgn : Assign; + W : Wire_Id; + begin + Res := 0; + for I in Alts'Range loop + Asgn := Alts (I).Asgns; + while Asgn /= No_Assign loop + W := Get_Wire_Id (Asgn); + if not Wire_Id_Table.Table (W).Mark_Flag then + Res := Res + 1; + Wire_Id_Table.Table (W).Mark_Flag := True; + end if; + Asgn := Get_Assign_Chain (Asgn); + end loop; + end loop; + return Res; + end Count_Wires_In_Alternatives; + + procedure Fill_Wire_Id_Array (Arr : out Wire_Id_Array; + Alts : Alternative_Data_Array) + is + Idx : Natural; + Asgn : Assign; + W : Wire_Id; + begin + Idx := Arr'First; + for I in Alts'Range loop + Asgn := Alts (I).Asgns; + while Asgn /= No_Assign loop + W := Get_Wire_Id (Asgn); + if Wire_Id_Table.Table (W).Mark_Flag then + Arr (Idx) := W; + Idx := Idx + 1; + Wire_Id_Table.Table (W).Mark_Flag := False; + end if; + Asgn := Get_Assign_Chain (Asgn); + end loop; + end loop; + pragma Assert (Idx = Arr'Last + 1); + end Fill_Wire_Id_Array; + + type Case_Element is record + Sel : Uns64; + Val : Net; + end record; + + type Case_Element_Array is array (Natural range <>) of Case_Element; + type Case_Element_Array_Acc is access Case_Element_Array; + procedure Free_Case_Element_Array is new Ada.Unchecked_Deallocation + (Case_Element_Array, Case_Element_Array_Acc); + + -- Generate a netlist for a 'big' mux selected by SEL. The inputs are + -- described by ELS: E.Val must be selected when SEL = E.Sel; if there + -- is no E in Els for a value, DEFAULT is selected. + -- The result of the netlist is stored in RES. + -- + -- A tree of MUX4 is built. + -- + -- ELS must be sorted by SEL values. + -- ELS is overwritten/modified so after the call it contains garbage. The + -- reason is that ELS might be large, so temporary arrays are not allocated + -- on the stack, and ELS is expected to be built only for this subprogram. + procedure Synth_Case (Sel : Net; + Els : in out Case_Element_Array; + Default : Net; + Res : out Net) + is + Wd : constant Width := Get_Width (Sel); + Mask : Uns64; + Sub_Sel : Net; + Lels : Natural; + Iels : Natural; + Oels : Natural; + begin + Lels := Els'Last; + Iels := Els'First; + + if Lels < Iels then + -- No choices + Res := Default; + return; + end if; + + -- Handle SEL bits by 2, so group case_element by 4. + for I in 1 .. Natural (Wd / 2) loop + Sub_Sel := Build_Slice (Build_Context, + Sel, Width (2 * (I - 1)), 2); + Mask := Shift_Left (not 0, Natural (2 * I)); + Iels := Els'First; + Oels := Els'First; + while Iels <= Lels loop + declare + type Net4 is array (0 .. 3) of Net; + G : Net4; + S_Group : constant Uns64 := Els (Iels).Sel and Mask; + S_El : Uns64; + El_Idx : Natural; + begin + G := (others => Default); + for K in 0 .. 3 loop + exit when Iels > Lels; + S_El := Els (Iels).Sel; + exit when (S_El and Mask) /= S_Group; + El_Idx := Natural + (Shift_Right (S_El, Natural (2 * (I - 1))) and 3); + G (El_Idx) := Els (Iels).Val; + Iels := Iels + 1; + end loop; + Els (Oels) := + (Sel => S_Group, + Val => Build_Mux4 (Build_Context, + Sub_Sel, G (0), G (1), G (2), G (3))); + Oels := Oels + 1; + end; + end loop; + Lels := Oels - 1; + end loop; + + -- If the width is not a multiple of 2, handle the last level. + if Wd mod 2 = 1 then + Sub_Sel := Build_Extract_Bit (Build_Context, Sel, Wd - 1); + Iels := Els'First; + Oels := Els'First; + while Iels <= Lels loop + declare + type Net2 is array (0 .. 1) of Net; + G : Net2; + S_Group : constant Uns64 := Els (Iels).Sel and Mask; + S_El : Uns64; + El_Idx : Natural; + begin + G := (others => Default); + for K in 0 .. 1 loop + exit when Iels > Lels; + S_El := Els (Iels).Sel; + El_Idx := Natural + (Shift_Right (S_El, Natural (Wd - 1)) and 1); + G (El_Idx) := Els (Iels).Val; + Iels := Iels + 1; + end loop; + Els (Oels) := + (Sel => S_Group, + Val => Build_Mux2 (Build_Context, Sub_Sel, G (0), G (1))); + Oels := Oels + 1; + end; + end loop; + Lels := Oels - 1; + end if; + pragma Assert (Lels = Els'First); + Res := Els (Els'First).Val; + end Synth_Case; + + procedure Synth_Case_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Iir) + is + use Sem_Expr; + + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); + Choices : constant Iir := Get_Case_Statement_Alternative_Chain (Stmt); + Choice : Iir; + + Case_Info : Choice_Info_Type; + Annex_Arr : Annex_Array_Acc; + Alts : Alternative_Data_Acc; + Alt_Idx : Alternative_Index; + Choice_Data : Choice_Data_Array_Acc; + Choice_Idx : Natural; + Others_Alt_Idx : Alternative_Index; + Case_El : Case_Element_Array_Acc; + + Nbr_Wires : Natural; + Wires : Wire_Id_Array_Acc; + + Sel : Value_Acc; + Sel_Net : Net; + begin + -- TODO: handle enum, bit, integers... + if Get_Kind (Get_Base_Type (Expr_Type)) + = Iir_Kind_Enumeration_Type_Definition + and then not Is_Bit_Type (Expr_Type) + then + -- State machine. + raise Internal_Error; + end if; + + -- Strategies to synthesize a case statement. Assume the selector is + -- a net of W bits + -- - a large mux, with 2**W inputs + -- - if the number of choices is dense + -- - if W is small + -- - a onehot mux. Each choice is converted to an single bit condition + -- by adding a comparison operator (equal for single choice, + -- inequalities for ranges, or for multiple choices). Only one of + -- these conditions is true (plus 'others'). + -- - if the number of choices is sparse + -- - large range choices + -- - a tree of mux/mux2 + -- - large number of choices, densily grouped but sparsed compared + -- to 2**W (eg: a partially filled memory) + -- - divide and conquier + + -- Create a wire for the expression. + Sel := Synth_Expression (Syn_Inst, Expr); + + -- Count choices and alternatives. + Count_Choices (Case_Info, Choices); + Fill_Choices_Array (Case_Info, Choices); + + -- Allocate structures. + -- Because there is no 1-1 link between choices and alternatives, + -- create an array for the choices and an array for the alternatives. + Alts := new Alternative_Data_Array + (1 .. Alternative_Index (Case_Info.Nbr_Alternatives)); + Choice_Data := new Choice_Data_Array (1 .. Case_Info.Nbr_Choices); + Annex_Arr := new Annex_Array (1 .. Case_Info.Nbr_Choices); + Case_Info.Annex_Arr := Annex_Arr; + + -- Synth statements, extract choice value. + Alt_Idx := 0; + Others_Alt_Idx := 0; + Choice_Idx := 0; + Choice := Choices; + while Is_Valid (Choice) loop + if not Get_Same_Alternative_Flag (Choice) then + Alt_Idx := Alt_Idx + 1; + + declare + Phi : Phi_Type; + begin + Push_Phi; + Synth_Sequential_Statements + (Syn_Inst, Get_Associated_Chain (Choice)); + Pop_Phi (Phi); + Alts (Alt_Idx).Asgns := Sort_Phi (Phi); + end; + end if; + + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Expression => + Choice_Idx := Choice_Idx + 1; + Annex_Arr (Choice_Idx) := Int32 (Alt_Idx); + declare + Choice_Expr : constant Iir := Get_Choice_Expression (Choice); + Val, Dc : Uns64; + begin + Convert_To_Uns64 (Choice_Expr, Val, Dc); + if Dc = 0 then + Choice_Data (Choice_Idx) := (Val => Val, + Alt => Alt_Idx); + else + Error_Msg_Synth (+Choice_Expr, "meta-values never match"); + Choice_Data (Choice_Idx) := (Val => 0, + Alt => 0); + end if; + end; + when Iir_Kind_Choice_By_Others => + Others_Alt_Idx := Alt_Idx; + when others => + raise Internal_Error; + end case; + Choice := Get_Chain (Choice); + end loop; + pragma Assert (Choice_Idx = Choice_Data'Last); + + Sort_String_Choices (Case_Info); + + -- Create list of wire_id, sort it. + Nbr_Wires := Count_Wires_In_Alternatives (Alts.all); + Wires := new Wire_Id_Array (1 .. Nbr_Wires); + Fill_Wire_Id_Array (Wires.all, Alts.all); + + -- Sort Wires. + Sort_Wire_Id_Array (Wires.all); + + -- Associate each choice with the assign node + -- For each wire_id: + -- Build mux2/mux4 tree (group by 4) + Case_El := new Case_Element_Array (1 .. Case_Info.Nbr_Choices); + + Sel_Net := Get_Net (Sel); + + for I in Wires'Range loop + declare + Wi : constant Wire_Id := Wires (I); + Last_Val : constant Net := Get_Last_Assigned_Value (Wi); + Res : Net; + Default : Net; + begin + -- Extract the value for each alternative. + for Alt of Alts.all loop + -- If there is an assignment to Wi in Alt, it will define the + -- value. Otherwise, use Last_Val, ie the last assignment + -- before the case. + if Get_Wire_Id (Alt.Asgns) = Wi then + Alt.Val := Get_Assign_Value (Alt.Asgns); + Alt.Asgns := Get_Assign_Chain (Alt.Asgns); + else + Alt.Val := Last_Val; + end if; + end loop; + + -- Build the map between choices and values. + for J in Choice_Data'Range loop + Case_El (J) := (Sel => Choice_Data (J).Val, + Val => Alts (Choice_Data (J).Alt).Val); + end loop; + + -- Extract default value (for missing alternative). + if Others_Alt_Idx /= 0 then + Default := Alts (Others_Alt_Idx).Val; + else + Default := No_Net; + end if; + + -- Generate the muxes tree. + Synth_Case (Sel_Net, Case_El.all, Default, Res); + Phi_Assign (Wi, Res); + end; + end loop; + + -- free. + Free_Case_Element_Array (Case_El); + Free_Wire_Id_Array (Wires); + Free_Choice_Data_Array (Choice_Data); + Free_Annex_Array (Annex_Arr); + Free_Alternative_Data_Array (Alts); + end Synth_Case_Statement; + + procedure Synth_Subprogram_Association + (Subprg_Inst : Synth_Instance_Acc; + Caller_Inst : Synth_Instance_Acc; + Inter_Chain : Iir; + Assoc_Chain : Iir) + is + use Annotations; + Inter : Iir; + Assoc : Iir; + Assoc_Inter : Iir; + Actual : Iir; + Val : Value_Acc; + Slot : Object_Slot_Type; + begin + Assoc := Assoc_Chain; + Assoc_Inter := Inter_Chain; + while Is_Valid (Assoc) loop + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Inter); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when others => + raise Internal_Error; + end case; + + case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration => + -- FIXME: Arguments are passed by copy. + Elaboration.Create_Object (Subprg_Inst.Sim, Inter); + when Iir_Kind_Interface_Signal_Declaration => + Elaboration.Create_Signal (Subprg_Inst.Sim, Inter); + when Iir_Kind_Interface_File_Declaration => + raise Internal_Error; + end case; + + case Iir_Parameter_Modes (Get_Mode (Inter)) is + when Iir_In_Mode => + Val := Synth_Expression_With_Type + (Caller_Inst, Actual, Get_Type (Inter)); + Slot := Get_Info (Inter).Slot; + Subprg_Inst.Objects (Slot) := Val; + when Iir_Out_Mode => + Synth_Declaration (Subprg_Inst, Inter); + when Iir_Inout_Mode => + -- FIXME: todo + raise Internal_Error; + end case; + + Next_Association_Interface (Assoc, Assoc_Inter); + end loop; + end Synth_Subprogram_Association; + + procedure Synth_Subprogram_Back_Association + (Subprg_Inst : Synth_Instance_Acc; + Caller_Inst : Synth_Instance_Acc; + Inter_Chain : Iir; + Assoc_Chain : Iir) + is + use Annotations; + Inter : Iir; + Assoc : Iir; + Assoc_Inter : Iir; + Val : Value_Acc; + begin + Assoc := Assoc_Chain; + Assoc_Inter := Inter_Chain; + while Is_Valid (Assoc) loop + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + + if Get_Mode (Inter) = Iir_Out_Mode then + Val := Synth_Expression_With_Type + (Subprg_Inst, Inter, Get_Type (Inter)); + Synth_Assignment (Caller_Inst, Get_Actual (Assoc), Val); + + end if; + + Next_Association_Interface (Assoc, Assoc_Inter); + end loop; + end Synth_Subprogram_Back_Association; + + procedure Synth_Procedure_Call + (Syn_Inst : Synth_Instance_Acc; Stmt : Iir) + is + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Call); + Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); + Subprg_Body : constant Iir := Get_Subprogram_Body (Imp); + Decls_Chain : constant Iir := Get_Declaration_Chain (Subprg_Body); + Sub_Sim_Inst : Block_Instance_Acc; + Sub_Syn_Inst : Synth_Instance_Acc; + begin + if Get_Implicit_Definition (Imp) in Iir_Predefined_Implicit then + Error_Msg_Synth (+Stmt, "call to implicit %n is not supported", +Imp); + return; + elsif Get_Foreign_Flag (Imp) then + Error_Msg_Synth (+Stmt, "call to foreign %n is not supported", +Imp); + return; + end if; + + Areapools.Mark (Syn_Inst.Sim.Marker, Instance_Pool.all); + Sub_Sim_Inst := + Execution.Create_Subprogram_Instance (Syn_Inst.Sim, null, Imp); + Sub_Syn_Inst := Make_Instance (Sub_Sim_Inst); + + Synth_Subprogram_Association + (Sub_Syn_Inst, Syn_Inst, Inter_Chain, Assoc_Chain); + + Elaborate_Declarative_Part (Sub_Sim_Inst, Decls_Chain); + + if Is_Valid (Decls_Chain) then + Sub_Syn_Inst.Name := New_Sname (Syn_Inst.Name, Get_Identifier (Imp)); + Synth_Declarations (Sub_Syn_Inst, Decls_Chain); + end if; + + Synth_Sequential_Statements + (Sub_Syn_Inst, Get_Sequential_Statement_Chain (Subprg_Body)); + + Synth_Subprogram_Back_Association + (Sub_Syn_Inst, Syn_Inst, Inter_Chain, Assoc_Chain); + + Free_Instance (Sub_Syn_Inst); + end Synth_Procedure_Call; + + procedure Synth_Sequential_Statements + (Syn_Inst : Synth_Instance_Acc; Stmts : Iir) + is + Stmt : Iir; + begin + Stmt := Stmts; + while Is_Valid (Stmt) loop + case Get_Kind (Stmt) is + when Iir_Kind_If_Statement => + Synth_If_Statement (Syn_Inst, Stmt); + when Iir_Kind_Simple_Signal_Assignment_Statement => + Synth_Simple_Signal_Assignment (Syn_Inst, Stmt); + when Iir_Kind_Variable_Assignment_Statement => + Synth_Variable_Assignment (Syn_Inst, Stmt); + when Iir_Kind_Case_Statement => + Synth_Case_Statement (Syn_Inst, Stmt); + when Iir_Kind_Null_Statement => + -- Easy + null; + when Iir_Kind_Procedure_Call_Statement => + Synth_Procedure_Call (Syn_Inst, Stmt); + when others => + Error_Kind ("synth_sequential_statements", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Synth_Sequential_Statements; + + Proc_Pool : aliased Areapools.Areapool; + + procedure Synth_Process_Statement + (Syn_Inst : Synth_Instance_Acc; Sim_Inst : Block_Instance_Acc; Proc : Iir) + is + use Areapools; + pragma Assert (Sim_Inst.Label = Proc); + Decls_Chain : constant Iir := Get_Declaration_Chain (Proc); + Proc_Inst : Synth_Instance_Acc; + M : Areapools.Mark_Type; + begin + Proc_Inst := Make_Instance (Sim_Inst); + Mark (M, Proc_Pool); + Instance_Pool := Proc_Pool'Access; + Elaborate_Declarative_Part (Sim_Inst, Decls_Chain); + + if Is_Valid (Decls_Chain) then + Proc_Inst.Name := New_Sname (Syn_Inst.Name, Get_Identifier (Proc)); + Synth_Declarations (Proc_Inst, Decls_Chain); + end if; + + Synth_Sequential_Statements + (Proc_Inst, Get_Sequential_Statement_Chain (Proc)); + + Free_Instance (Proc_Inst); + Release (M, Proc_Pool); + Instance_Pool := null; + end Synth_Process_Statement; + + procedure Synth_Statements (Syn_Inst : Synth_Instance_Acc; Stmts : Iir) + is + Sim_Child : Block_Instance_Acc; + Stmt : Iir; + begin + Sim_Child := Syn_Inst.Sim.Children; + Stmt := Stmts; + while Is_Valid (Stmt) loop + Push_Phi; + case Get_Kind (Stmt) is + when Iir_Kind_Concurrent_Simple_Signal_Assignment => + Synth_Simple_Signal_Assignment (Syn_Inst, Stmt); + when Iir_Kind_Sensitized_Process_Statement => + Synth_Process_Statement (Syn_Inst, Sim_Child, Stmt); + Sim_Child := Sim_Child.Brother; + when others => + Error_Kind ("synth_statements", Stmt); + end case; + Pop_And_Merge_Phi (Build_Context); + Stmt := Get_Chain (Stmt); + end loop; + end Synth_Statements; +end Synth.Stmts; diff --git a/src/synth/synth-stmts.ads b/src/synth/synth-stmts.ads new file mode 100644 index 000000000..dd314e167 --- /dev/null +++ b/src/synth/synth-stmts.ads @@ -0,0 +1,27 @@ +-- Statements 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Iirs; use Iirs; +with Synth.Values; use Synth.Values; + +package Synth.Stmts is + -- Generate netlists for concurrent statements STMTS. + procedure Synth_Statements (Syn_Inst : Synth_Instance_Acc; Stmts : Iir); +end Synth.Stmts; diff --git a/src/synth/synth-types.adb b/src/synth/synth-types.adb new file mode 100644 index 000000000..0efe3f4da --- /dev/null +++ b/src/synth/synth-types.adb @@ -0,0 +1,78 @@ +-- Types 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Std_Package; +with Ieee.Std_Logic_1164; +with Iirs_Utils; use Iirs_Utils; + +with Iir_Values; use Iir_Values; +with Execution; +with Errorout; use Errorout; + +package body Synth.Types is + function Is_Bit_Type (Atype : Iir) return Boolean is + begin + return Atype = Ieee.Std_Logic_1164.Std_Ulogic_Type + or else Atype = Ieee.Std_Logic_1164.Std_Logic_Type + or else Atype = Std_Package.Boolean_Type_Definition + or else Atype = Std_Package.Bit_Type_Definition; + end Is_Bit_Type; + + function Is_Vector_Type (Atype : Iir) return Boolean is + begin + return Is_Bit_Type (Get_Element_Subtype (Atype)) + and then Get_Nbr_Dimensions (Atype) = 1; + end Is_Vector_Type; + + function Get_Width (Syn_Inst : Synth_Instance_Acc; Atype : Iir) + return Width + is + Btype : constant Iir := Get_Base_Type (Atype); + begin + case Get_Kind (Atype) is + when Iir_Kind_Enumeration_Type_Definition => + if Is_Bit_Type (Atype) then + return 1; + else + raise Internal_Error; + end if; + when Iir_Kind_Enumeration_Subtype_Definition => + -- Tail call + return Get_Width (Syn_Inst, Btype); + when Iir_Kind_Array_Subtype_Definition => + if Is_Vector_Type (Btype) then + declare + Bnd : Iir_Value_Literal_Acc; + begin + Bnd := Execution.Execute_Bounds + (Syn_Inst.Sim, + Get_Nth_Element (Get_Index_Subtype_List (Atype), 0)); + return Width (Bnd.Length); + end; + else + raise Internal_Error; + end if; + when others => + Error_Kind ("get_width", Atype); + end case; + end Get_Width; + +end Synth.Types; diff --git a/src/synth/synth-types.ads b/src/synth/synth-types.ads new file mode 100644 index 000000000..934edbb53 --- /dev/null +++ b/src/synth/synth-types.ads @@ -0,0 +1,33 @@ +-- Types 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Netlists; use Netlists; +with Synth.Values; use Synth.Values; +with Iirs; use Iirs; + +package Synth.Types is + -- All known enumeration type that are translated to a single bit. + function Is_Bit_Type (Atype : Iir) return Boolean; + + function Is_Vector_Type (Atype : Iir) return Boolean; + + function Get_Width (Syn_Inst : Synth_Instance_Acc; Atype : Iir) + return Width; +end Synth.Types; diff --git a/src/synth/synth-values.adb b/src/synth/synth-values.adb new file mode 100644 index 000000000..238341627 --- /dev/null +++ b/src/synth/synth-values.adb @@ -0,0 +1,144 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Ada.Unchecked_Conversion; +with System; +with Areapools; + +package body Synth.Values is + function To_Value_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Acc); + function To_Value_Range_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Range_Acc); + function To_Value_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Values.Value_Array_Acc); + + function Create_Value_Wire (W : Wire_Id; Rng : Value_Range_Acc) + 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, + W_Range => Rng))); + end Create_Value_Wire; + + function Create_Value_Net (N : Net; Rng : Value_Range_Acc) 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, N_Range => Rng))); + end Create_Value_Net; + + function Create_Value_Lit (Val : Iir_Value_Literal_Acc; Typ : Iir) + return Value_Acc + is + subtype Value_Type_Lit is Value_Type (Value_Lit); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Lit); + begin + return To_Value_Acc + (Alloc (Current_Pool, + (Kind => Value_Lit, Lit => Val, Lit_Type => Typ))); + end Create_Value_Lit; + + function Bounds_To_Nbr_Elements (Bounds : Value_Bounds_Array_Acc) + return Iir_Index32 + is + Len : Iir_Index32; + begin + Len := 1; + for I in Bounds.D'Range loop + Len := Len * Bounds.D (I).Length; + end loop; + return Len; + end Bounds_To_Nbr_Elements; + + procedure Create_Array_Data (Arr : Value_Acc) + is + use System; + use Areapools; + Len : constant Iir_Index32 := Bounds_To_Nbr_Elements (Arr.Bounds); + + subtype Data_Type is Values.Value_Array_Type (Len); + 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; + + Arr.Arr := To_Value_Array_Acc (Res); + end Create_Array_Data; + + function Create_Array_Value (Bounds : Value_Bounds_Array_Acc) + return Value_Acc + is + subtype Value_Type_Array is Value_Type (Values.Value_Array); + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Array); + + Res : Value_Acc; + begin + Res := To_Value_Acc + (Alloc (Current_Pool, + (Kind => Values.Value_Array, + Arr => null, Bounds => Bounds))); + Create_Array_Data (Res); + return Res; + end Create_Array_Value; + + function Create_Range_Value (Rng : Value_Range) return Value_Range_Acc + is + function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Range); + begin + return To_Value_Range_Acc (Alloc (Current_Pool, Rng)); + end Create_Range_Value; + + function Bounds_To_Range (Val : Iir_Value_Literal_Acc) + return Value_Range_Acc + is + pragma Assert (Val.Kind = Iir_Value_Range); + pragma Assert (Val.Left.Kind = Iir_Value_I64); + pragma Assert (Val.Right.Kind = Iir_Value_I64); + begin + return Create_Range_Value ((Dir => Val.Dir, + Len => Width (Val.Length), + Left => Int32 (Val.Left.I64), + Right => Int32 (Val.Right.I64))); + end Bounds_To_Range; +end Synth.Values; diff --git a/src/synth/synth-values.ads b/src/synth/synth-values.ads new file mode 100644 index 000000000..5929d6345 --- /dev/null +++ b/src/synth/synth-values.ads @@ -0,0 +1,120 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Netlists; use Netlists; +with Synth.Environment; use Synth.Environment; +with Annotations; use Annotations; +with Elaboration; use Elaboration; +with Iir_Values; use Iir_Values; +with Iirs; use Iirs; + +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_Net, Value_Wire, Value_Array, Value_Record, + Value_Lit); + + type Value_Type (Kind : Value_Kind); + + type Value_Acc is access Value_Type; + + type Value_Type_Array is array (Iir_Index32 range <>) of Value_Acc; + + type Value_Array_Type (Len : Iir_Index32) is record + V : Value_Type_Array (1 .. Len); + end record; + + type Value_Array_Acc is access Value_Array_Type; + + type Value_Range is record + Dir : Iir_Direction; + Len : Width; + Left : Int32; + Right : Int32; + end record; + + type Value_Range_Acc is access Value_Range; + No_Range : constant Value_Range_Acc := null; + + type Value_Type (Kind : Value_Kind) is record + case Kind is + when Value_Net => + N : Net; + N_Range : Value_Range_Acc; + when Value_Wire => + W : Wire_Id; + W_Range : Value_Range_Acc; + when Value_Lit => + Lit : Iir_Values.Iir_Value_Literal_Acc; + Lit_Type : Iir; + when Value_Array => + Arr : Value_Array_Acc; + Bounds : Value_Bounds_Array_Acc; + when Value_Record => + Rec : Value_Array_Acc; + end case; + end record; + + -- Create a Value_Net. + function Create_Value_Net (N : Net; Rng : Value_Range_Acc) return Value_Acc; + + -- Create a Value_Wire. For a bit wire, RNG must be null. + function Create_Value_Wire (W : Wire_Id; Rng : Value_Range_Acc) + return Value_Acc; + + -- Create a Value_Lit. + function Create_Value_Lit (Val : Iir_Value_Literal_Acc; Typ : Iir) + return Value_Acc; + + -- Create a Value_Array. + function Create_Array_Value (Bounds : Value_Bounds_Array_Acc) + return Value_Acc; + + -- Allocate the ARR component of the Value_Type ARR, using BOUNDS. + procedure Create_Array_Data (Arr : Value_Acc); + + -- Allocate a Value_Range. + function Create_Range_Value (Rng : Value_Range) return Value_Range_Acc; + + -- Create a Value_Range from a simulation bound. + function Bounds_To_Range (Val : Iir_Value_Literal_Acc) + return Value_Range_Acc; + + -- Values are stored into Synth_Instance, which is parallel to simulation + -- Block_Instance_Type. + type Objects_Array is array (Object_Slot_Type range <>) of Value_Acc; + + type Synth_Instance_Type (Max_Objs : Object_Slot_Type) is record + -- Module which owns gates created for this instance. + M : Module; + + -- Name prefix for declarations. + Name : Sname; + + Sim : Block_Instance_Acc; + Objects : Objects_Array (1 .. Max_Objs); + end record; + + type Synth_Instance_Acc is access Synth_Instance_Type; + +end Synth.Values; diff --git a/src/synth/synth.ads b/src/synth/synth.ads new file mode 100644 index 000000000..39a1cb528 --- /dev/null +++ b/src/synth/synth.ads @@ -0,0 +1,23 @@ +-- Synthesis root namespace. +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +package Synth is + pragma Pure; +end Synth; diff --git a/src/synth/synthesis.adb b/src/synth/synthesis.adb new file mode 100644 index 000000000..6361db001 --- /dev/null +++ b/src/synth/synthesis.adb @@ -0,0 +1,261 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; +with Name_Table; use Name_Table; + +with Netlists.Builders; use Netlists.Builders; + +with Iirs_Utils; use Iirs_Utils; +with Elaboration; use Elaboration; + +with Synth.Environment; use Synth.Environment; +with Synth.Values; use Synth.Values; +with Synth.Context; use Synth.Context; +with Synth.Types; use Synth.Types; +with Synth.Decls; use Synth.Decls; +with Synth.Stmts; use Synth.Stmts; + +with Synth.Environment.Debug; +pragma Unreferenced (Synth.Environment.Debug); + +with Errorout; use Errorout; + +package body Synthesis is + function Mode_To_Port_Kind (Mode : Iir_Mode) return Port_Kind is + begin + case Mode is + when Iir_In_Mode => + return Port_In; + when Iir_Buffer_Mode + | Iir_Out_Mode + | Iir_Inout_Mode => + return Port_Out; + when Iir_Linkage_Mode + | Iir_Unknown_Mode => + raise Synth_Error; + end case; + end Mode_To_Port_Kind; + + function Get_Nbr_Wire (Val : Value_Acc) return Uns32 is + begin + case Val.Kind is + when Value_Wire => + return 1; + when others => + raise Internal_Error; -- TODO + end case; + end Get_Nbr_Wire; + + procedure Make_Port_Desc (Val : Value_Acc; + Name : Sname; + Wd : Width; + Ports : in out Port_Desc_Array; + Idx : in out Port_Nbr; + Dir : Port_Kind) + is + begin + case Val.Kind is + when Value_Wire => + Idx := Idx + 1; + Ports (Idx) := (Name => Name, + W => Wd, + Dir => Dir, + Left | Right => 0); + when others => + raise Internal_Error; -- TODO + end case; + end Make_Port_Desc; + + procedure Make_Port_Desc (Syn_Inst : Synth_Instance_Acc; + Inter : Iir; + Ports : in out Port_Desc_Array; + Idx : in out Port_Nbr; + Dir : Port_Kind) + is + Val : constant Value_Acc := Get_Value (Syn_Inst, Inter); + Wd : constant Width := Get_Width (Syn_Inst, Get_Type (Inter)); + Name : Sname; + begin + Name := New_Sname_User (Get_Identifier (Inter)); + Make_Port_Desc (Val, Name, Wd, Ports, Idx, Dir); + end Make_Port_Desc; + + procedure Create_Input_Wire + (Self_Inst : Instance; Idx : in out Port_Idx; Val : Value_Acc) is + begin + case Val.Kind is + when Value_Wire => + Wire_Id_Table.Table (Val.W).Gate := Get_Output (Self_Inst, Idx); + Idx := Idx + 1; + when others => + raise Internal_Error; + end case; + end Create_Input_Wire; + + procedure Create_Output_Wire + (Self_Inst : Instance; Idx : in out Port_Idx; Val : Value_Acc) + is + Value : Net; + Inp : Input; + W : Width; + begin + case Val.Kind is + when Value_Wire => + -- Create a gate for the output, so that it could be read. + W := Get_Output_Desc (Get_Module (Self_Inst), Idx).W; + Value := Build_Output (Build_Context, W); + Inp := Get_Input (Self_Inst, Idx); + Connect (Inp, Value); + Wire_Id_Table.Table (Val.W).Gate := Value; + Idx := Idx + 1; + when others => + raise Internal_Error; + end case; + end Create_Output_Wire; + + function Synth_Entity + (Parent : Module; Arch : Iir; Sim_Inst : Block_Instance_Acc) + return Synth_Instance_Acc + is + Entity : constant Iir := Get_Entity (Arch); + Syn_Inst : Synth_Instance_Acc; + Self_Inst : Instance; + Inter : Iir; + Nbr_Inputs : Port_Nbr; + Nbr_Outputs : Port_Nbr; + Num : Uns32; + begin + Syn_Inst := Make_Instance (Sim_Inst); + Syn_Inst.Name := New_Sname_User (Get_Identifier (Entity)); + + -- Allocate values and count inputs and outputs + Inter := Get_Port_Chain (Entity); + Nbr_Inputs := 0; + Nbr_Outputs := 0; + while Is_Valid (Inter) loop + case Mode_To_Port_Kind (Get_Mode (Inter)) is + when Port_In => + Make_Object (Syn_Inst, Wire_Input, Inter); + Num := Get_Nbr_Wire (Get_Value (Syn_Inst, Inter)); + Nbr_Inputs := Nbr_Inputs + Port_Nbr (Num); + when Port_Out + | Port_Inout => + Make_Object (Syn_Inst, Wire_Output, Inter); + Num := Get_Nbr_Wire (Get_Value (Syn_Inst, Inter)); + Nbr_Outputs := Nbr_Outputs + Port_Nbr (Num); + end case; + Inter := Get_Chain (Inter); + end loop; + + -- Declare module. + Syn_Inst.M := + New_User_Module (Parent, New_Sname_User (Get_Identifier (Entity)), + Id_User_None, Nbr_Inputs, Nbr_Outputs, 0); + + -- Add ports to module. + declare + Inports : Port_Desc_Array (1 .. Nbr_Inputs); + Outports : Port_Desc_Array (1 .. Nbr_Outputs); + begin + Inter := Get_Port_Chain (Entity); + Nbr_Inputs := 0; + Nbr_Outputs := 0; + while Is_Valid (Inter) loop + case Mode_To_Port_Kind (Get_Mode (Inter)) is + when Port_In => + Make_Port_Desc + (Syn_Inst, Inter, Inports, Nbr_Inputs, Port_In); + when Port_Out + | Port_Inout => + Make_Port_Desc + (Syn_Inst, Inter, Outports, Nbr_Outputs, Port_Out); + end case; + Inter := Get_Chain (Inter); + end loop; + pragma Assert (Nbr_Inputs = Inports'Last); + pragma Assert (Nbr_Outputs = Outports'Last); + Set_Port_Desc (Syn_Inst.M, Inports, Outports); + end; + + Self_Inst := Create_Self_Instance (Syn_Inst.M); + Set_Parent (Build_Context, Syn_Inst.M); + + -- Create wires for inputs and outputs. + Inter := Get_Port_Chain (Entity); + Nbr_Inputs := 0; + Nbr_Outputs := 0; + while Is_Valid (Inter) loop + case Mode_To_Port_Kind (Get_Mode (Inter)) is + when Port_In => + Create_Input_Wire + (Self_Inst, Nbr_Inputs, Get_Value (Syn_Inst, Inter)); + when Port_Out + | Port_Inout => + Create_Output_Wire + (Self_Inst, Nbr_Outputs, Get_Value (Syn_Inst, Inter)); + end case; + Inter := Get_Chain (Inter); + end loop; + + Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Entity)); + Synth_Statements (Syn_Inst, Get_Concurrent_Statement_Chain (Entity)); + + Synth_Declarations (Syn_Inst, Get_Declaration_Chain (Arch)); + Synth_Statements (Syn_Inst, Get_Concurrent_Statement_Chain (Arch)); + + Remove_Free_Instances (Syn_Inst.M); + + return Syn_Inst; + end Synth_Entity; + + function Synth_Design (Design : Iir) return Module + is + Unit : constant Iir := Get_Library_Unit (Design); + Arch : Iir; + + Des : Module; + Syn_Inst : Synth_Instance_Acc; + begin + -- Extract architecture from design. + case Get_Kind (Unit) is + when Iir_Kind_Architecture_Body => + Arch := Unit; + when Iir_Kind_Configuration_Declaration => + Arch := Get_Named_Entity + (Get_Block_Specification (Get_Block_Configuration (Unit))); + when others => + Error_Kind ("synth_design", Unit); + end case; + + Instance_Map := new Instance_Map_Array (0 .. Nbr_Block_Instances); + + Des := New_Design (New_Sname_Artificial (Get_Identifier ("top"))); + Build_Context := Build_Builders (Des); + Syn_Inst := Synth_Entity (Des, Arch, Top_Instance); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + pragma Unreferenced (Syn_Inst); + return Des; + end Synth_Design; +end Synthesis; diff --git a/src/synth/synthesis.ads b/src/synth/synthesis.ads new file mode 100644 index 000000000..e1abbfb67 --- /dev/null +++ b/src/synth/synthesis.ads @@ -0,0 +1,28 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Iirs; use Iirs; +with Netlists; use Netlists; + +package Synthesis is + function Synth_Design (Design : Iir) return Module; + + Synth_Error : exception; +end Synthesis; |