diff options
Diffstat (limited to 'src')
50 files changed, 1743 insertions, 302 deletions
diff --git a/src/ghdldrv/ghdlsynth.adb b/src/ghdldrv/ghdlsynth.adb index 7a55cafee..5d76355aa 100644 --- a/src/ghdldrv/ghdlsynth.adb +++ b/src/ghdldrv/ghdlsynth.adb @@ -43,6 +43,7 @@ with Vhdl.Utils; with Netlists.Dump; with Netlists.Disp_Vhdl; +with Netlists.Disp_Verilog; with Netlists.Disp_Dot; with Netlists.Errors; @@ -56,6 +57,7 @@ package body Ghdlsynth is (Format_Default, Format_Raw, Format_Dump, Format_Dot, Format_Vhdl, Format_Raw_Vhdl, + Format_Verilog, Format_None); type Name_Id_Array is array (Natural range <>) of Name_Id; @@ -203,6 +205,8 @@ package body Ghdlsynth is Cmd.Oformat := Format_Vhdl; elsif Option = "--out=raw-vhdl" then Cmd.Oformat := Format_Raw_Vhdl; + elsif Option = "--out=verilog" then + Cmd.Oformat := Format_Verilog; elsif Option = "-di" then Flag_Debug_Noinference := True; elsif Option = "-dc" then @@ -435,10 +439,17 @@ package body Ghdlsynth is when Format_Dot => Netlists.Disp_Dot.Disp_Dot_Top_Module (Res); when Format_Vhdl => - Ent := Vhdl.Utils.Get_Entity_From_Configuration (Config); - Synth.Disp_Vhdl.Disp_Vhdl_Wrapper (Ent, Res, Inst); + if Get_Kind (Config) = Iir_Kind_Foreign_Module then + -- Not a VHDL design. + Netlists.Disp_Vhdl.Disp_Vhdl (Res); + else + Ent := Vhdl.Utils.Get_Entity_From_Configuration (Config); + Synth.Disp_Vhdl.Disp_Vhdl_Wrapper (Ent, Res, Inst); + end if; when Format_Raw_Vhdl => Netlists.Disp_Vhdl.Disp_Vhdl (Res); + when Format_Verilog => + Netlists.Disp_Verilog.Disp_Verilog (Res); end case; end Disp_Design; diff --git a/src/grt/Makefile.inc b/src/grt/Makefile.inc index 860c91344..6e4b741e0 100644 --- a/src/grt/Makefile.inc +++ b/src/grt/Makefile.inc @@ -153,8 +153,8 @@ grt/run-bind.o: grt grt/run-bind.adb grt/main.o: grt $(GRTSRCDIR)/main.adb cd grt && $(MSYS2_ARG) $(GRT_ADACOMPILE) -o main.o $(GRTSRCDIR)/main.adb -Igrt -GRT_C_COMPILE = $(CC) -c $(GRT_FLAGS) -o $@ $< -GRT_C_COMPILE_PIC = $(CC) -c $(GRT_FLAGS) $(PIC_FLAGS) -o $@ $< +GRT_C_COMPILE = $(CC) -c $(GRT_FLAGS) $(CFLAGS) -o $@ $< +GRT_C_COMPILE_PIC = $(CC) -c $(GRT_FLAGS) $(PIC_FLAGS) $(CFLAGS) -o $@ $< jumps.o: $(GRTSRCDIR)/config/jumps.c $(GRT_C_COMPILE) diff --git a/src/grt/ghdl_main.adb b/src/grt/ghdl_main.adb index b9121122c..92e69c362 100644 --- a/src/grt/ghdl_main.adb +++ b/src/grt/ghdl_main.adb @@ -42,7 +42,7 @@ is function To_Argv_Type is new Ada.Unchecked_Conversion (Source => System.Address, Target => Grt.Options.Argv_Type); - Args : Grt.Options.Argv_Type := To_Argv_Type (Argv); + Args : constant Grt.Options.Argv_Type := To_Argv_Type (Argv); Progname : Ghdl_C_String := null; begin -- Ada elaboration. diff --git a/src/grt/grt-table.adb b/src/grt/grt-table.adb index 89fc043ad..a800b8c25 100644 --- a/src/grt/grt-table.adb +++ b/src/grt/grt-table.adb @@ -39,7 +39,8 @@ package body Grt.Table is pragma Import (C, Free); -- Resize and reallocate the table according to LAST_VAL. - procedure Resize is + procedure Resize + is function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr; pragma Import (C, Realloc); @@ -49,8 +50,10 @@ package body Grt.Table is Max := Max + (Max - Table_Low_Bound + 1); end loop; - New_Size := size_t ((Max - Table_Low_Bound + 1) * - (Table_Type'Component_Size / Storage_Unit)); + -- Do the multiplication using size_t to avoid overflow if the bounds + -- are a 32bit type on a 64bit machine. + New_Size := (size_t (Max - Table_Low_Bound + 1) + * size_t (Table_Type'Component_Size / Storage_Unit)); Table := Realloc (Table, New_Size); @@ -113,6 +116,6 @@ begin Last_Val := Table_Index_Type'Pred (Table_Low_Bound); Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1; - Table := Malloc (size_t (Table_Initial * - (Table_Type'Component_Size / Storage_Unit))); + Table := Malloc (size_t (Table_Initial) + * size_t (Table_Type'Component_Size / Storage_Unit)); end Grt.Table; diff --git a/src/ortho/debug/Makefile b/src/ortho/debug/Makefile index 885ff0d55..d7d297c1b 100644 --- a/src/ortho/debug/Makefile +++ b/src/ortho/debug/Makefile @@ -23,14 +23,13 @@ CC=gcc CFLAGS=-g ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwaeu -gnatf -gnaty3befhkmr GNATMAKE_FLAGS=$(ALL_GNAT_FLAGS) $(GNATFLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI. -#LARGS=-largs -static SED=sed all: $(ortho_exec) $(ortho_exec): force $(ortho_srcdir)/$(BE)/ortho_debug.ads - $(GNATMAKE) -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS) + $(GNATMAKE) -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E -largs $(LDFLAGS) clean: $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main diff --git a/src/ortho/gcc/Makefile b/src/ortho/gcc/Makefile index 5b12ea569..498aa99d0 100644 --- a/src/ortho/gcc/Makefile +++ b/src/ortho/gcc/Makefile @@ -69,7 +69,7 @@ $(ortho_exec): $(AGCC_DEPS) $(orthobe_srcdir)/ortho_gcc.ads force $(GNATMAKE) -o $@ -aI$(ortho_srcdir) \ -aI$(ortho_srcdir)/gcc $(GNATFLAGS) ortho_gcc-main \ -bargs -E -largs --LINK=$(LINKER) $(AGCC_OBJS) \ - $(BACKEND) $(LIBS) $(BACKENDLIBS) + $(LDFLAGS) $(BACKEND) $(LIBS) $(BACKENDLIBS) agcc-clean: force $(RM) -f $(agcc_objdir)/*.o diff --git a/src/ortho/gcc/ortho-lang-49.c b/src/ortho/gcc/ortho-lang-49.c index d2c3dfc52..e8b4f5643 100644 --- a/src/ortho/gcc/ortho-lang-49.c +++ b/src/ortho/gcc/ortho-lang-49.c @@ -50,6 +50,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1139,6 +1141,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1303,6 +1312,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1313,6 +1323,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/gcc/ortho-lang-5.c b/src/ortho/gcc/ortho-lang-5.c index 8daa5dd92..6a3d5cdb8 100644 --- a/src/ortho/gcc/ortho-lang-5.c +++ b/src/ortho/gcc/ortho-lang-5.c @@ -66,6 +66,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1125,6 +1127,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1289,6 +1298,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1299,6 +1309,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/gcc/ortho-lang-6.c b/src/ortho/gcc/ortho-lang-6.c index 244b26c6c..d2f15cc51 100644 --- a/src/ortho/gcc/ortho-lang-6.c +++ b/src/ortho/gcc/ortho-lang-6.c @@ -66,6 +66,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1125,6 +1127,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1289,6 +1298,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1299,6 +1309,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/gcc/ortho-lang-7.c b/src/ortho/gcc/ortho-lang-7.c index a5b97d8c6..4600fc602 100644 --- a/src/ortho/gcc/ortho-lang-7.c +++ b/src/ortho/gcc/ortho-lang-7.c @@ -66,6 +66,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1137,6 +1139,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1301,6 +1310,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1311,6 +1321,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/gcc/ortho-lang-8.c b/src/ortho/gcc/ortho-lang-8.c index 2c37bdbf5..f88cea0c1 100644 --- a/src/ortho/gcc/ortho-lang-8.c +++ b/src/ortho/gcc/ortho-lang-8.c @@ -66,6 +66,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1138,6 +1140,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1302,6 +1311,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1312,6 +1322,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/gcc/ortho-lang-9.c b/src/ortho/gcc/ortho-lang-9.c index 66e7d7ab0..b7dfab4f3 100644 --- a/src/ortho/gcc/ortho-lang-9.c +++ b/src/ortho/gcc/ortho-lang-9.c @@ -66,6 +66,8 @@ #include "stor-layout.h" #include "varasm.h" +#define TYPE_UNBOUNDED(t) TYPE_LANG_FLAG_0(t) + /* Returns the number of FIELD_DECLs in TYPE. Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ @@ -1138,6 +1140,13 @@ new_record_union_field (struct o_element_list *list, { tree res; + if (TYPE_UNBOUNDED(etype)) { + /* If the field type is unbounded, it mustn't use any space in the + record. Use VOID instead. */ + TYPE_UNBOUNDED(list->res) = 1; + etype = void_type_node; + } + res = build_decl (input_location, FIELD_DECL, ident, etype); DECL_CONTEXT (res) = list->res; chain_append (&list->chain, res); @@ -1302,6 +1311,7 @@ new_array_type (tree el_type, tree index_type) /* Build an incomplete array. */ range_type = build_range_type (index_type, size_zero_node, NULL_TREE); res = build_array_type (el_type, range_type); + TYPE_UNBOUNDED(res) = 1; return res; } @@ -1312,6 +1322,7 @@ new_array_subtype (tree atype, tree eltype, tree length) tree index_type; tree res; + gcc_assert(!TYPE_UNBOUNDED(eltype)); index_type = TYPE_DOMAIN (atype); range_type = ortho_build_array_range(index_type, length); diff --git a/src/ortho/llvm-nodebug/Makefile b/src/ortho/llvm-nodebug/Makefile index 50ddc1bc5..880735857 100644 --- a/src/ortho/llvm-nodebug/Makefile +++ b/src/ortho/llvm-nodebug/Makefile @@ -12,7 +12,7 @@ $(ortho_exec): $(ortho_srcdir)/llvm-nodebug/ortho_llvm.ads force llvm-cbindings. $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm-nodebug -aI$(ortho_srcdir) \ $(GNATFLAGS) ortho_code_main -bargs -E \ -largs llvm-cbindings.o --LINK=$(CXX) \ - $(LDFLAGS) `$(LLVM_CONFIG) --ldflags --libs --system-libs` + `$(LLVM_CONFIG) --ldflags --libs --system-libs` $(LDFLAGS) llvm-cbindings.o: $(ortho_srcdir)/llvm-nodebug/llvm-cbindings.cpp $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< diff --git a/src/ortho/llvm35/Makefile b/src/ortho/llvm35/Makefile index 5abe441da..33aee4cf5 100644 --- a/src/ortho/llvm35/Makefile +++ b/src/ortho/llvm35/Makefile @@ -12,7 +12,7 @@ $(ortho_exec): $(ortho_srcdir)/llvm35/ortho_llvm.ads force llvm-cbindings.o $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \ $(GNATFLAGS) ortho_code_main -bargs -E \ -largs llvm-cbindings.o --LINK=$(CXX) \ - $(LDFLAGS) `$(LLVM_CONFIG) --ldflags --libs --system-libs` + `$(LLVM_CONFIG) --ldflags --libs --system-libs` $(LDFLAGS) llvm-cbindings.o: $(ortho_srcdir)/llvm35/llvm-cbindings.cpp $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< diff --git a/src/ortho/llvm4-nodebug/Makefile b/src/ortho/llvm4-nodebug/Makefile index f3be7dbde..b5fd22a8a 100644 --- a/src/ortho/llvm4-nodebug/Makefile +++ b/src/ortho/llvm4-nodebug/Makefile @@ -14,7 +14,7 @@ $(ortho_exec): $(ortho_srcdir)/llvm4-nodebug/ortho_llvm.ads force llvm-cbindings $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm4-nodebug -aI$(ortho_srcdir) \ $(GNATFLAGS) ortho_code_main -bargs -E \ -largs llvm-cbindings.o --LINK=$(CXX) \ - $(LDFLAGS) `$(LLVM_LDFLAGS)` + `$(LLVM_LDFLAGS)` $(LDFLAGS) llvm-cbindings.o: $(ortho_srcdir)/llvm4-nodebug/llvm-cbindings.cpp $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< diff --git a/src/ortho/llvm6/Makefile b/src/ortho/llvm6/Makefile index 31f25c9fa..073512817 100644 --- a/src/ortho/llvm6/Makefile +++ b/src/ortho/llvm6/Makefile @@ -14,10 +14,10 @@ $(ortho_exec): $(ortho_srcdir)/llvm6/ortho_llvm.ads force llvm-cbindings.o $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm6 -aI$(ortho_srcdir) \ $(GNATFLAGS) ortho_code_main -bargs -E \ -largs llvm-cbindings.o --LINK=$(CXX) \ - $(LDFLAGS) `$(LLVM_LDFLAGS)` + `$(LLVM_LDFLAGS)` $(LDFLAGS) llvm-cbindings.o: $(ortho_srcdir)/llvm6/llvm-cbindings.cpp - $(CXX) -c `$(LLVM_CONFIG) --cxxflags` $(CFLAGS) -o $@ $< + $(CXX) -c `$(LLVM_CONFIG) --cxxflags` $(CXXFLAGS) -o $@ $< clean: $(RM) -f *.o *.ali ortho_code_main diff --git a/src/ortho/llvm6/llvm-cbindings.cpp b/src/ortho/llvm6/llvm-cbindings.cpp index 98470d8fa..2f5cebe83 100644 --- a/src/ortho/llvm6/llvm-cbindings.cpp +++ b/src/ortho/llvm6/llvm-cbindings.cpp @@ -376,8 +376,12 @@ struct OTnodeBase { DIType *Dbg; #endif + // Kind of type. OTKind Kind; + + // If true, the type is bounded: all the elements have a defined size. bool Bounded; + OTnodeBase (LLVMTypeRef R, OTKind K, bool Bounded) : Ref(R), #ifdef USE_DEBUG @@ -643,7 +647,7 @@ struct OElementList { OFKind Kind; // Number of fields. - unsigned Count; + unsigned BndCount; // For record: the access to the incomplete (but named) type. OTnode RecType; @@ -685,9 +689,10 @@ extern "C" void new_record_field(OElementList *Elements, OFnodeRec **El, OIdent Ident, OTnode Etype) { - *El = new OFnodeRec(Etype, Ident, Elements->Count); + *El = new OFnodeRec(Etype, Ident, Etype->Bounded ? Elements->BndCount : ~0U); Elements->Els->push_back(*El); - Elements->Count++; + if (Etype->Bounded) + Elements->BndCount++; } struct OTnodeRecBase : OTnodeBase { @@ -710,16 +715,19 @@ struct OTnodeIncompleteRec : OTnodeRecBase { static DINodeArray buildDebugRecordElements(OTnodeRecBase *Atype) { - unsigned Count = Atype->Els.size(); - std::vector<Metadata *> els(Count); + std::vector<Metadata *> els; + + els.reserve(Atype->Els.size()); unsigned i = 0; for (OFnodeBase *e : Atype->Els) { - unsigned bitoff = 8 * LLVMOffsetOfElement(TheTargetData, Atype->Ref, i); - els[i++] = DBuilder->createMemberType - (DebugCurrentSubprg, StringRef(e->Ident.cstr), NULL, 0, - e->FType->getBitSize(), /* align */ 0, - bitoff, DINode::DIFlags::FlagZero, e->FType->Dbg); + if (!e->FType->Bounded) + break; + unsigned bitoff = 8 * LLVMOffsetOfElement(TheTargetData, Atype->Ref, i++); + els.push_back(DBuilder->createMemberType + (DebugCurrentSubprg, StringRef(e->Ident.cstr), NULL, 0, + e->FType->getBitSize(), /* align */ 0, + bitoff, DINode::DIFlags::FlagZero, e->FType->Dbg)); } return DBuilder->getOrCreateArray(els); @@ -729,21 +737,24 @@ buildDebugRecordElements(OTnodeRecBase *Atype) extern "C" void finish_record_type(OElementList *Els, OTnode *Res) { - LLVMTypeRef *Types = new LLVMTypeRef[Els->Count]; + LLVMTypeRef *Types = new LLVMTypeRef[Els->BndCount]; // Create types array for elements. int i = 0; bool Bounded = true; for (OFnodeBase *Field : *Els->Els) { - Bounded &= Field->FType->Bounded; - Types[i++] = Field->FType->Ref; + if (Field->FType->Bounded) + Types[i++] = Field->FType->Ref; + else + Bounded = false; } + assert(i == Els->BndCount); OTnodeRecBase *T; if (Els->RecType != nullptr) { // Completion - LLVMStructSetBody (Els->RecType->Ref, Types, Els->Count, 0); + LLVMStructSetBody (Els->RecType->Ref, Types, Els->BndCount, 0); Els->RecType->Bounded = Bounded; T = static_cast<OTnodeRecBase *>(Els->RecType); T->Els = std::move(*Els->Els); @@ -762,7 +773,7 @@ finish_record_type(OElementList *Els, OTnode *Res) } else { // Non-completion. // Debug info are created when the type is declared. - T = new OTnodeRec(LLVMStructType(Types, Els->Count, 0), Bounded); + T = new OTnodeRec(LLVMStructType(Types, Els->BndCount, 0), Bounded); T->Els = std::move(*Els->Els); } *Res = T; diff --git a/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile index 791d1f307..25f3c664b 100644 --- a/src/ortho/mcode/Makefile +++ b/src/ortho/mcode/Makefile @@ -10,13 +10,13 @@ all: $(ortho_exec) $(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force $(GNATMAKE) -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \ -aI$(ortho_srcdir)/.. $(GNATFLAGS) -gnatw.A ortho_code_main \ - -bargs -E -largs memsegs_c.o #-static + -bargs -E -largs $(LDFLAGS) memsegs_c.o #-static memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c $(CC) -c $(CFLAGS) -o $@ $< oread: $(ortho_srcdir)/mcode/ortho_mcode.ads force - $(GNATMAKE) -m -o $@ -g $(GNATFLAGS) -aI../oread ortho_code_main -aI.. -largs memsegs_c.o + $(GNATMAKE) -m -o $@ -g $(GNATFLAGS) -aI../oread ortho_code_main -aI.. -largs $(LDFLAGS) memsegs_c.o elfdump: force $(GNATMAKE) -m -g $(GNATFLAGS) $@ diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb index 2e08b7ab0..e6bf6b6a3 100644 --- a/src/ortho/oread/ortho_front.adb +++ b/src/ortho/oread/ortho_front.adb @@ -2114,13 +2114,16 @@ package body Ortho_Front is declare V : O_Enode; Bt : Node_Acc; + El_Type : Node_Acc; Res_Type : Node_Acc; begin Next_Token; if N_Type.Kind = Type_Subarray then Bt := N_Type.Subarray_Base; + El_Type := N_Type.Subarray_El; else Bt := N_Type; + El_Type := N_Type.Array_Element; end if; if Bt.Kind /= Type_Array then Parse_Error ("type of prefix is not an array"); @@ -2131,7 +2134,7 @@ package body Ortho_Front is Next_Token; else N := New_Indexed_Element (N, V); - N_Type := Bt.Array_Element; + N_Type := El_Type; end if; Expect (Tok_Right_Brack); Next_Token; diff --git a/src/std_names.adb b/src/std_names.adb index b9eeea05e..ffbfce1ef 100644 --- a/src/std_names.adb +++ b/src/std_names.adb @@ -792,7 +792,7 @@ package body Std_Names is Def ("valueof", Name_Valueof); Def ("valueOf", Name_uValueof); - -- VHDL special comments + -- Special comments Def ("psl", Name_Psl); Def ("pragma", Name_Pragma); Def ("synthesis", Name_Synthesis); @@ -803,6 +803,8 @@ package body Std_Names is Def ("synthesis_off", Name_Synthesis_Off); Def ("synthesis_on", Name_Synthesis_On); Def ("off", Name_Off); + Def ("full_case", Name_Full_Case); + Def ("parallel_case", Name_Parallel_Case); -- PSL keywords Def ("a", Name_A); diff --git a/src/std_names.ads b/src/std_names.ads index 46b7542df..45558cb48 100644 --- a/src/std_names.ads +++ b/src/std_names.ads @@ -920,7 +920,7 @@ package Std_Names is -- while Name_Last_BSV : constant Name_Id := Name_First_BSV + 49; - -- VHDL special comments + -- Special comments Name_First_Comment : constant Name_Id := Name_Last_BSV + 1; Name_Psl : constant Name_Id := Name_First_Comment + 0; Name_Pragma : constant Name_Id := Name_First_Comment + 1; @@ -932,7 +932,9 @@ package Std_Names is Name_Synthesis_Off : constant Name_Id := Name_First_Comment + 7; Name_Synthesis_On : constant Name_Id := Name_First_Comment + 8; Name_Off : constant Name_Id := Name_First_Comment + 9; - Name_Last_Comment : constant Name_Id := Name_Off; + Name_Full_Case : constant Name_Id := Name_First_Comment + 10; + Name_Parallel_Case : constant Name_Id := Name_First_Comment + 11; + Name_Last_Comment : constant Name_Id := Name_Parallel_Case; -- PSL words. Name_First_PSL : constant Name_Id := Name_Last_Comment + 1; diff --git a/src/synth/netlists-cleanup.adb b/src/synth/netlists-cleanup.adb index 2f741e3f3..d7d74b83d 100644 --- a/src/synth/netlists-cleanup.adb +++ b/src/synth/netlists-cleanup.adb @@ -112,6 +112,35 @@ package body Netlists.Cleanup is end loop; end Remove_Unconnected_Instances; + procedure Remove_Output_Gate (Inst : Instance) + is + use Netlists.Gates; + Inp : constant Input := Get_Input (Inst, 0); + In_Drv : constant Net := Get_Driver (Inp); + O : constant Net := Get_Output (Inst, 0); + begin + if In_Drv = O then + -- Connected to itself. + -- TODO: convert to initial value or to X. + return; + end if; + + if In_Drv /= No_Net then + -- Only when the output is driven. + Disconnect (Inp); + Redirect_Inputs (O, In_Drv); + else + Disconnect (Get_First_Sink (O)); + end if; + + if Get_Id (Inst) = Id_Ioutput then + -- Disconnect the initial value. + Disconnect (Get_Input (Inst, 1)); + end if; + + Remove_Instance (Inst); + end Remove_Output_Gate; + procedure Remove_Output_Gates (M : Module) is use Netlists.Gates; @@ -130,29 +159,7 @@ package body Netlists.Cleanup is | Id_Nop => -- Keep gates with an attribute. if not Has_Attribute (Inst) then - declare - Inp : Input; - In_Drv : Net; - O : Net; - begin - Inp := Get_Input (Inst, 0); - In_Drv := Get_Driver (Inp); - O := Get_Output (Inst, 0); - if In_Drv /= No_Net then - -- Only when the output is driven. - Disconnect (Inp); - Redirect_Inputs (O, In_Drv); - else - Disconnect (Get_First_Sink (O)); - end if; - - if Get_Id (Inst) = Id_Ioutput then - -- Disconnect the initial value. - Disconnect (Get_Input (Inst, 1)); - end if; - - Remove_Instance (Inst); - end; + Remove_Output_Gate (Inst); end if; when others => null; diff --git a/src/synth/netlists-disp_verilog.adb b/src/synth/netlists-disp_verilog.adb new file mode 100644 index 000000000..c0c6f0c0a --- /dev/null +++ b/src/synth/netlists-disp_verilog.adb @@ -0,0 +1,1346 @@ +-- Disp a netlist in verilog. +-- Copyright (C) 2021 Tristan Gingold +-- +-- This file is part of GHDL. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see <gnu.org/licenses>. + +with Simple_IO; use Simple_IO; +with Utils_IO; use Utils_IO; +with Types_Utils; use Types_Utils; +with Files_Map; + +with Netlists.Utils; use Netlists.Utils; +with Netlists.Iterators; use Netlists.Iterators; +with Netlists.Gates; use Netlists.Gates; +with Netlists.Locations; +with Netlists.Dump; use Netlists.Dump; + +package body Netlists.Disp_Verilog is + Flag_Merge_Lit : constant Boolean := True; + Flag_Merge_Edge : constant Boolean := True; + + procedure Put_Type (W : Width) is + begin + if W > 1 then + Put ("["); + Put_Uns32 (W - 1); + Put (":0] "); + end if; + end Put_Type; + + procedure Put_Name_Version (N : Sname) is + begin + Put_Uns32 (Get_Sname_Version (N)); + end Put_Name_Version; + + procedure Put_Name_1 (N : Sname) + is + Prefix : Sname; + begin + -- Do not crash on No_Name. + if N = No_Sname then + Put ("*nil*"); + return; + end if; + + Prefix := Get_Sname_Prefix (N); + if Prefix /= No_Sname then + Put_Name_1 (Prefix); + Put ("_"); + end if; + + case Get_Sname_Kind (N) is + when Sname_User => + Put_Id (Get_Sname_Suffix (N)); + when Sname_Artificial => + Put_Id (Get_Sname_Suffix (N)); + when Sname_Version => + Put ("n"); + Put_Name_Version (N); + end case; + end Put_Name_1; + + procedure Put_Name (N : Sname) is + begin + -- Do not crash on No_Name. + if N = No_Sname then + Put ("*nil*"); + return; + end if; + + if Get_Sname_Kind (N) = Sname_User + and then Get_Sname_Prefix (N) = No_Sname + then + Put_Id (Get_Sname_Suffix (N)); + else + Put_Name_1 (N); + end if; + end Put_Name; + + procedure Put_Interface_Name (N : Sname) is + begin + -- Do not crash on No_Name. + if N = No_Sname then + Put ("*nil*"); + return; + end if; + + -- Interface names are not versionned. + if Get_Sname_Kind (N) in Sname_User .. Sname_Artificial then + Put_Name (N); + else + Put ("*err*"); + end if; + end Put_Interface_Name; + + procedure Disp_Net_Name (N : Net) is + begin + if N = No_Net then + Put ("<unassigned>"); + return; + end if; + + declare + Inst : constant Instance := Get_Net_Parent (N); + Idx : constant Port_Idx := Get_Port_Idx (N); + M : Module; + Inst_Name : Sname; + Port_Name : Sname; + begin + if Is_Self_Instance (Inst) then + -- For ports of the current module, simply use the port name. + Put_Name (Get_Input_Desc (Get_Module (Inst), Idx).Name); + else + Inst_Name := Get_Instance_Name (Inst); + Put_Name (Inst_Name); + M := Get_Module (Inst); + case Get_Id (M) is + when Id_Signal + | Id_Isignal => + -- No suffix for signals (it's 'o'). + null; + when others => + Port_Name := Get_Output_Desc (M, Idx).Name; + Put ("_"); + Put_Interface_Name (Port_Name); + end case; + end if; + end; + end Disp_Net_Name; + + procedure Disp_Instance_Gate (Inst : Instance) + is + Imod : constant Module := Get_Module (Inst); + Idx : Port_Idx; + Max_Idx : Port_Idx; + Name : Sname; + First : Boolean; + Param : Param_Desc; + begin + Put (" "); + + -- Gate name + Name := Get_Module_Name (Imod); + if Get_Id (Imod) < Id_User_None then + Put (" gate_"); + pragma Assert (Get_Sname_Kind (Name) = Sname_Artificial + and then Get_Sname_Prefix (Name) = No_Sname); + Put_Id (Get_Sname_Suffix (Name)); + else + Put_Name (Name); + end if; + + -- Instance name + Put (" "); + Name := Get_Instance_Name (Inst); + if Get_Sname_Kind (Name) = Sname_Version then + Put ("inst_"); + Put_Name_Version (Name); + else + Put_Name (Name); + end if; + + if Get_Nbr_Params (Imod) /= 0 then + Put_Line (" #("); + for P in 1 .. Get_Nbr_Params (Inst) loop + Param := Get_Param_Desc (Imod, P - 1); + if P > 1 then + Put_Line (","); + end if; + Put (" ."); + Put_Interface_Name (Param.Name); + Put ("("); + case Param.Typ is + when Param_Uns32 => + Put_Uns32 (Get_Param_Uns32 (Inst, P - 1)); + when Param_Types_Pval => + Disp_Pval_Binary (Get_Param_Pval (Inst, P - 1)); + when Param_Invalid => + Put ("*invalid*"); + end case; + Put (")"); + end loop; + Put_Line (")"); + Put_Line (" ("); + else + Put_Line (" ("); + end if; + + First := True; + -- Inputs + Idx := 0; + Max_Idx := Get_Nbr_Inputs (Imod); + for I of Inputs (Inst) loop + if First then + First := False; + else + Put_Line (","); + end if; + Put (" "); + if Idx < Max_Idx then + Put ("."); + Put_Interface_Name (Get_Input_Desc (Imod, Idx).Name); + Put ("("); + end if; + Disp_Net_Name (Get_Driver (I)); + if Idx < Max_Idx then + Put (")"); + Idx := Idx + 1; + end if; + end loop; + -- Outputs + Idx := 0; + for O of Outputs (Inst) loop + if First then + First := False; + else + Put_Line (","); + end if; + Put (" ."); + Put_Interface_Name (Get_Output_Desc (Imod, Idx).Name); + Idx := Idx + 1; + Put ("("); + declare + I : Input; + begin + I := Get_First_Sink (O); + if I = No_Input then + Put ("open"); + else + Disp_Net_Name (O); + end if; + end; + Put (")"); + end loop; + Put_Line (");"); + end Disp_Instance_Gate; + + procedure Disp_Binary_Lit (Va : Uns32; Zx : Uns32; Wd : Width) is + begin + Put_Uns32 (Wd); + Put ("'b"); + Disp_Binary_Digits (Va, Zx, Natural (Wd)); + end Disp_Binary_Lit; + + procedure Disp_Const_Bit (Inst : Instance) + is + W : constant Width := Get_Width (Get_Output (Inst, 0)); + Nd : constant Width := W / 32; + Ld : constant Natural := Natural (W mod 32); + begin + Put ('"'); + if Ld > 0 then + Disp_Binary_Digits (Get_Param_Uns32 (Inst, Param_Idx (Nd)), 0, Ld); + end if; + for I in reverse 1 .. Nd loop + Disp_Binary_Digits + (Get_Param_Uns32 (Inst, Param_Idx (I - 1)), 0, 32); + end loop; + Put ('"'); + end Disp_Const_Bit; + + procedure Disp_Const_Log (Inst : Instance) + is + W : constant Width := Get_Width (Get_Output (Inst, 0)); + Nd : constant Width := W / 32; + Ld : constant Natural := Natural (W mod 32); + begin + Put ('"'); + if Ld > 0 then + Disp_Binary_Digits (Get_Param_Uns32 (Inst, Param_Idx (2 * Nd)), + Get_Param_Uns32 (Inst, Param_Idx (2 * Nd + 1)), + Ld); + end if; + for I in reverse 1 .. Nd loop + Disp_Binary_Digits + (Get_Param_Uns32 (Inst, Param_Idx (2 * (I - 1))), + Get_Param_Uns32 (Inst, Param_Idx (2 * (I - 1)) + 1), + 32); + end loop; + Put ('"'); + end Disp_Const_Log; + + procedure Disp_X_Lit (W : Width; C : Character) is + begin + Put_Uns32 (W); + Put ("'b"); + Put (C); + end Disp_X_Lit; + + procedure Disp_Extract (Inst : Instance); + + procedure Disp_Constant_Inline (Inst : Instance) + is + Imod : constant Module := Get_Module (Inst); + O : constant Net := Get_Output (Inst, 0); + begin + case Get_Id (Imod) is + when Id_Const_UB32 + | Id_Const_SB32 => + Disp_Binary_Lit (Get_Param_Uns32 (Inst, 0), 0, Get_Width (O)); + when Id_Const_UL32 => + Disp_Binary_Lit (Get_Param_Uns32 (Inst, 0), + Get_Param_Uns32 (Inst, 1), + Get_Width (O)); + when Id_Const_Z => + Disp_X_Lit (Get_Width (O), 'Z'); + when Id_Const_X => + Disp_X_Lit (Get_Width (O), 'X'); + when Id_Const_Bit => + Disp_Const_Bit (Inst); + when Id_Const_Log => + Disp_Const_Log (Inst); + when Id_Extract => + Disp_Extract (Inst); + when others => + raise Internal_Error; + end case; + end Disp_Constant_Inline; + + procedure Disp_Const_Bit (Inst : Instance; Off : Uns32) + is + Val : Uns32; + Zx : Uns32; + begin + case Get_Id (Inst) is + when Id_Const_Bit => + Zx := 0; + Val := Get_Param_Uns32 (Inst, Param_Idx (Off / 32)); + Val := Shift_Right (Val, Natural (Off mod 32)) and 1; + when Id_Const_Log => + Zx := Get_Param_Uns32 (Inst, 2 * Param_Idx (Off / 32) + 1); + Zx := Shift_Right (Zx, Natural (Off mod 32)) and 1; + Val := Get_Param_Uns32 (Inst, 2 * Param_Idx (Off / 32)); + Val := Shift_Right (Val, Natural (Off mod 32)) and 1; + when Id_Const_UB32 => + Zx := 0; + if Off < 32 then + Val := Get_Param_Uns32 (Inst, 0); + Val := Shift_Right (Val, Natural (Off mod 32)) and 1; + else + Val := 0; + end if; + when Id_Const_UL32 => + if Off < 32 then + Val := Get_Param_Uns32 (Inst, 0); + Val := Shift_Right (Val, Natural (Off mod 32)) and 1; + Zx := Get_Param_Uns32 (Inst, 1); + Zx := Shift_Right (Zx, Natural (Off mod 32)) and 1; + else + Val := 0; + Zx := 0; + end if; + when Id_Const_X => + Zx := 1; + Val := 1; + when others => + raise Internal_Error; + end case; + Put (Bchar (Zx * 2 + Val)); + end Disp_Const_Bit; + + procedure Disp_Memory_Init (Port : Net; Val : Net; W : Width; Depth : Width) + is + Inst : constant Instance := Get_Net_Parent (Val); + begin + case Get_Id (Inst) is + when Id_Const_X => + return; + when others => + null; + end case; + + Put_Line (" initial begin"); + for I in reverse 0 .. Depth - 1 loop + Put (" "); + Disp_Net_Name (Port); + Put ("["); + Put_Uns32 (I); + Put ("] = "); + Put_Uns32 (W); + Put ("'b"); + for J in reverse 0 .. W - 1 loop + Disp_Const_Bit (Inst, I * W + J); + end loop; + Put_Line (";"); + end loop; + Put_Line (" end"); + end Disp_Memory_Init; + + function Need_Name (Inst : Instance) return Boolean + is + Id : constant Module_Id := Get_Id (Inst); + begin + case Id is + when Id_Extract + | Id_Dyn_Extract + | Id_Dyn_Insert + | Id_Utrunc + | Id_Strunc => + return True; + when Id_User_None .. Module_Id'Last => + return True; + when others => + return False; + end case; + end Need_Name; + + -- Return True if constant INST is connected to an instance that needs + -- a name. In that case, a signal will be created and driven. + function Need_Signal (Inst : Instance) return Boolean + is + I : Input; + begin + I := Get_First_Sink (Get_Output (Inst, 0)); + while I /= No_Input loop + if Need_Name (Get_Input_Parent (I)) then + return True; + end if; + I := Get_Next_Sink (I); + end loop; + return False; + end Need_Signal; + + -- Return TRUE if edge INST (posedge or negedge) is used outside clock + -- inputs. + function Need_Edge (Inst : Instance) return Boolean + is + I : Input; + Parent : Instance; + begin + I := Get_First_Sink (Get_Output (Inst, 0)); + while I /= No_Input loop + Parent := Get_Input_Parent (I); + case Get_Id (Parent) is + when Id_Dff + | Id_Adff + | Id_Idff + | Id_Iadff => + if I /= Get_Input (Parent, 0) then + return True; + end if; + when Id_Mem_Rd_Sync + | Id_Mem_Wr_Sync => + if I /= Get_Input (Parent, 2) then + return True; + end if; + when others => + return True; + end case; + I := Get_Next_Sink (I); + end loop; + return False; + end Need_Edge; + + type Conv_Type is + (Conv_None, Conv_Unsigned, Conv_Signed, Conv_Edge, Conv_Clock); + + procedure Disp_Net_Expr (N : Net; Inst : Instance; Conv : Conv_Type) + is + Net_Inst : Instance; + begin + if N = No_Net then + Put ("<unassigned>"); + return; + end if; + + Net_Inst := Get_Net_Parent (N); + if Flag_Merge_Lit + and then Get_Id (Net_Inst) in Constant_Module_Id + and then not Need_Name (Inst) + then + case Conv is + when Conv_None => + Disp_Constant_Inline (Net_Inst); + when Conv_Unsigned => + Put ("$unsigned("); + Disp_Constant_Inline (Net_Inst); + Put (")"); + when Conv_Signed => + Put ("$signed("); + Disp_Constant_Inline (Net_Inst); + Put (")"); + when Conv_Edge + | Conv_Clock => + -- Not expected: a constant is not an edge. + raise Internal_Error; + end case; + else + case Conv is + when Conv_None => + Disp_Net_Name (N); + when Conv_Edge => + case Edge_Module_Id (Get_Id (Net_Inst)) is + when Id_Posedge => + Put ("posedge "); + when Id_Negedge => + Put ("negedge "); + end case; + Disp_Net_Name (Get_Input_Net (Net_Inst, 0)); + when Conv_Clock => + Disp_Net_Name (Get_Input_Net (Net_Inst, 0)); + when Conv_Unsigned => + Put ("$unsigned("); + Disp_Net_Name (N); + Put (")"); + when Conv_Signed => + Put ("$signed("); + Disp_Net_Name (N); + Put (")"); + end case; + end if; + end Disp_Net_Expr; + + NL : constant Character := ASCII.LF; + + type Uns32_Array is array (Natural range <>) of Uns32; + No_Uns32_Arr : constant Uns32_Array := (1 .. 0 => 0); + + -- Template: + -- \[C]AN + -- C: conversion u: unsigned, s: signed, f: force logic + -- A: argument o: output, i: input, n: value, p: parameter, l: label + -- N: argument number (0-9) + procedure Disp_Template + (S : String; Inst : Instance; Val : Uns32_Array := No_Uns32_Arr) + is + I : Positive; + C : Character; + Idx : Natural; + N : Net; + Conv : Conv_Type; + V : Uns32; + begin + I := S'First; + while I <= S'Last loop + C := S (I); + -- Escape character. + if C = '\' then + I := I + 1; + -- Conversion (optional). + case S (I) is + when 'u' => + Conv := Conv_Unsigned; + I := I + 1; + when 's' => + Conv := Conv_Signed; + I := I + 1; + when 'e' => + Conv := Conv_Edge; + I := I + 1; + when 'c' => + Conv := Conv_Clock; + I := I + 1; + when others => + Conv := Conv_None; + end case; + Idx := Character'Pos (S (I + 1)) - Character'Pos ('0'); + case S (I) is + when 'o' => + pragma Assert (Conv = Conv_None); + N := Get_Output (Inst, Port_Idx (Idx)); + Disp_Net_Name (N); + when 'i' => + N := Get_Input_Net (Inst, Port_Idx (Idx)); + Disp_Net_Expr (N, Inst, Conv); + when 'n' => + V := Val (Idx); + Put_Uns32 (V); + when 'p' => + V := Get_Param_Uns32 (Inst, Param_Idx (Idx)); + case Conv is + when Conv_None + | Conv_Unsigned => + Put_Uns32 (V); + when Conv_Signed => + Put_Int32 (To_Int32 (V)); + when Conv_Edge + | Conv_Clock => + raise Internal_Error; + end case; + when 'l' => + pragma Assert (Idx = 0); + pragma Assert (Conv = Conv_None); + Put_Name (Get_Instance_Name (Inst)); + when others => + raise Internal_Error; + end case; + + I := I + 2; + else + Put (C); + I := I + 1; + end if; + end loop; + end Disp_Template; + + procedure Disp_Extract (Inst : Instance) + is + O : constant Net := Get_Output (Inst, 0); + I : constant Net := Get_Input_Net (Inst, 0); + Wd : constant Width := Get_Width (O); + Off : constant Uns32 := Get_Param_Uns32 (Inst, 0); + begin + Disp_Template ("\i0", Inst); + if Get_Width (I) > 1 then + -- If width is 1, the signal is declared as a scalar and + -- therefore cannot be indexed. + if Wd > 1 then + Disp_Template ("[\n0:\n1]", Inst, + (0 => Off + Wd - 1, 1 => Off)); + elsif Wd = 1 then + Disp_Template ("[\n0]", Inst, (0 => Off)); + else + Disp_Template (" (-1 downto 0)", Inst); + end if; + end if; + end Disp_Extract; + + procedure Disp_Memory (Mem : Instance) + is + Ports : constant Net := Get_Output (Mem, 0); + Port : Net; + Port_Inst : Instance; + S : Net; + Data_W : Width; + Depth : Uns32; + begin + -- Display a process, with as sensitivity elements: + -- * write clocks + -- * read address + -- As statements: + Data_W := 0; + Port := Ports; + loop + Port_Inst := Get_Input_Parent (Get_First_Sink (Port)); + case Get_Id (Port_Inst) is + when Id_Mem_Wr_Sync => + -- Clock + S := Get_Input_Net (Port_Inst, 2); + -- Strip the edge. + S := Get_Input_Net (Get_Net_Parent (S), 0); + Data_W := Get_Width (Get_Input_Net (Port_Inst, 4)); + when Id_Mem_Rd => + -- Address + S := Get_Input_Net (Port_Inst, 1); + Data_W := Get_Width (Get_Output (Port_Inst, 1)); + when Id_Mem_Rd_Sync => + -- Clock + S := Get_Input_Net (Port_Inst, 2); + -- Strip the edge. + S := Get_Input_Net (Get_Net_Parent (S), 0); + Data_W := Get_Width (Get_Output (Port_Inst, 1)); + when Id_Memory + | Id_Memory_Init => + exit; + when others => + raise Internal_Error; + end case; + Port := Get_Output (Port_Inst, 0); + end loop; + + Depth := Get_Width (Ports) / Data_W; + + -- Declare the memory. + Put (" reg "); + Put_Type (Data_W); + Disp_Net_Name (Ports); + Put_Type (Depth); + Put_Line("; // memory"); + + -- Initialization + if Get_Id (Mem) = Id_Memory_Init then + declare + Val : Net; + Val_Inst : Instance; + begin + Val := Get_Input_Net (Mem, 1); + Val_Inst := Get_Net_Parent (Val); + if Get_Id (Val_Inst) = Id_Isignal then + Val := Get_Input_Net (Val_Inst, 1); + end if; + Disp_Memory_Init (Ports, Val, Data_W, Depth); + end; + end if; + + Port := Ports; + loop + Port_Inst := Get_Input_Parent (Get_First_Sink (Port)); + case Get_Id (Port_Inst) is + when Id_Mem_Wr_Sync => + Disp_Template + (" always @(\ei2)" & NL & + " if (\i3)" & NL, Port_Inst); + Disp_Template + (" \o0", Mem); + Disp_Template ("[\i1] <= \i4;" & NL, Port_Inst); + when Id_Mem_Rd => + Disp_Template (" assign \o1 = ", Port_Inst); + Disp_Template ("\o0", Mem); + Disp_Template ("[\i1];" & NL, Port_Inst); + when Id_Mem_Rd_Sync => + Disp_Template + (" always @(\ei2)" & NL & + " if (\i3)" & NL & + " \o1 <= ", Port_Inst); + Disp_Template ("\o0", Mem); + Disp_Template ("[\i1];" & NL, Port_Inst); + when Id_Memory + | Id_Memory_Init => + exit; + when others => + raise Internal_Error; + end case; + Port := Get_Output (Port_Inst, 0); + end loop; + end Disp_Memory; + + procedure Disp_Pmux (Inst : Instance) + is + Def : constant Net := Get_Input_Net (Inst, 0); + W : constant Width := Get_Width (Def); + begin + Disp_Template (" always @*" & NL & + " case (\i0)" & NL, Inst); + for I in 1 .. W loop + Put (" "); + -- One hot encoding. + Put_Uns32 (W); + Put ("'b"); + for J in 1 .. W loop + if I = J then + Put ('1'); + else + Put ('0'); + end if; + end loop; + Disp_Template (": \o0 <= ", Inst); + Disp_Net_Expr + (Get_Input_Net (Inst, Port_Idx (2 + W - I)), Inst, Conv_None); + Put_Line (";"); + end loop; + Disp_Template (" endcase" & NL, Inst); + end Disp_Pmux; + + procedure Disp_Instance_Inline (Inst : Instance) + is + Imod : constant Module := Get_Module (Inst); + Loc : constant Location_Type := Locations.Get_Location (Inst); + Id : constant Module_Id := Get_Id (Imod); + begin + if Loc /= No_Location then + declare + File : Name_Id; + Line : Positive; + Col : Natural; + begin + Files_Map.Location_To_Position (Loc, File, Line, Col); + Put (" /* "); + Put_Id (File); + Put (':'); + Put_Uns32 (Uns32 (Line)); + Put (':'); + Put_Uns32 (Uns32 (Col)); + Put (" */"); + New_Line; + end; + end if; + case Id is + when Id_Memory + | Id_Memory_Init => + Disp_Memory (Inst); + when Id_Mem_Rd + | Id_Mem_Rd_Sync + | Id_Mem_Wr_Sync => + null; + when Id_Output => + Disp_Template (" assign \o0 = \i0; // (output)" & NL, Inst); + when Id_Inout + | Id_Iinout => + -- Gates inout are special: output 1 must be connected to an + -- output (with the is_inout flag set) of the module. + Disp_Template (" assign \o1 = \i0; // (inout - port)" & NL, Inst); + Disp_Template (" assign \o0 = ", Inst); + declare + Inp : constant Input := Get_First_Sink (Get_Output (Inst, 1)); + Iinst : constant Instance := Get_Input_Parent (Inp); + begin + Put_Name (Get_Output_Name (Get_Module (Iinst), + Get_Port_Idx (Inp))); + end; + Put ("; // (inout - read)" & NL); + when Id_Signal => + Disp_Template (" assign \o0 = \i0; // (signal)" & NL, Inst); + when Id_Isignal => + if Get_Driver (Get_Input (Inst, 0)) /= No_Net then + -- It is possible (and meaningful) to have unassigned + -- isignal. + Disp_Template (" assign \o0 = \i0; // (isignal)" & NL, Inst); + end if; + when Id_Port => + Disp_Template (" \o0 <= \i0; -- (port)" & NL, Inst); + when Id_Nop => + Disp_Template (" \o0 <= \i0; -- (nop)" & NL, Inst); + when Id_Enable => + Disp_Template (" \o0 <= \i0; -- (enable)" & NL, Inst); + when Id_Not => + Disp_Template (" assign \o0 = ~\i0;" & NL, Inst); + when Id_Neg => + Disp_Template (" assign \o0 = -\i0;" & NL, Inst); + when Id_Abs=> + Disp_Template (" \o0 <= std_logic_vector(abs \si0);" & NL, Inst); + when Id_Extract => + Disp_Template (" assign \o0 = ", Inst); + Disp_Extract (Inst); + Put_Line (";"); + when Id_Memidx => + declare + Step : constant Uns32 := Get_Param_Uns32 (Inst, 0); + begin + Disp_Template + (" assign \o0 = \i0 * \p0;" & NL, Inst, (0 => Step)); + end; + when Id_Addidx => + declare + W0 : constant Width := Get_Width (Get_Input_Net (Inst, 0)); + W1 : constant Width := Get_Width (Get_Input_Net (Inst, 1)); + begin + if W0 > W1 then + Disp_Template + (" \o0 <= std_logic_vector (\ui0 + resize(\ui1, \n0));" + & NL, Inst, (0 => W0)); + elsif W0 < W1 then + Disp_Template + (" \o0 <= std_logic_vector (resize (\ui0, \n0) + \ui1);" + & NL, Inst, (0 => W1)); + else + pragma Assert (W0 = W1); + Disp_Template + (" \o0 <= std_logic_vector (\ui0 + \ui1);" + & NL, Inst); + end if; + end; + when Id_Dyn_Extract => + declare + O : constant Net := Get_Output (Inst, 0); + Wd : constant Width := Get_Width (O); + Off : constant Uns32 := Get_Param_Uns32 (Inst, 0); + begin + Disp_Template + (" assign \o0 = \i0[\i1 + \n0 -: \n1]; //(dyn_extract)" & NL, + Inst, (0 => Off, 1 => Wd)); + end; + when Id_Dyn_Insert + | Id_Dyn_Insert_En => + declare + -- I0: Input, I1: Value, I2: position + -- P0: offset + Iw : constant Width := Get_Width (Get_Input_Net (Inst, 1)); + begin + Put (" always @* begin // (dyn_insert)" & NL); + Disp_Template (" \o0 <= \i0;" & NL, Inst); + if Id = Id_Dyn_Insert_En then + -- TODO: fix indentation. + Disp_Template (" if (\i3)" & NL, Inst); + end if; + Disp_Template + (" \o0 [\i2 + \p0 -: \n0] <= \i1;" & NL, + Inst, (0 => Iw - 1)); + Disp_Template (" end" & NL, Inst); + end; + when Id_Const_UB32 + | Id_Const_UL32 + | Id_Const_Z + | Id_Const_X => + Disp_Template (" \o0 <= ", Inst); + Disp_Constant_Inline (Inst); + Put_Line (";"); + when Id_Const_Bit => + null; + when Id_Adff + | Id_Iadff => + Disp_Template (" always @(\ei0 or posedge \i2)" & NL & + " if (\i2)" & NL & + " \o0 <= \i3;" & NL & + " else" & NL & + " \o0 <= \i1;" & NL, Inst); + when Id_Dff + | Id_Idff => + Disp_Template (" always @(\ei0)" & NL & + " \o0 <= \i1;" & NL, Inst); + when Id_Mux2 => + Disp_Template (" assign \o0 = \i0 ? \i2 : \i1;" & NL, Inst); + when Id_Mux4 => + Disp_Template (" always @*" & NL & + " case (\i0)" & NL & + " 2'b00: \o0 <= \i1;" & NL & + " 2'b01: \o0 <= \i2;" & NL & + " 2'b10: \o0 <= \i3;" & NL & + " 2'b11: \o0 <= \i4;" & NL & + " endcase" & NL, Inst); + when Id_Pmux => + Disp_Pmux (Inst); + when Id_Add => + Disp_Template (" assign \o0 = \i0 + \i1;" & NL, Inst); + when Id_Sub => + Disp_Template (" assign \o0 = \i0 - \i1;" & NL, Inst); + when Id_Umin => + Disp_Template (" assign \o0 = (\i0 < \i1) ? \i0 : \i1;" & NL, + Inst); + when Id_Smin => + Disp_Template (" \o0 <= \i0 when \si0 < \si1 else \i1;" & NL, + Inst); + when Id_Umax => + Disp_Template (" assign \o0 = (\i0 > \i1) ? \i0 : \i1;" & NL, + Inst); + when Id_Smax => + Disp_Template (" \o0 <= \i0 when \si0 > \si1 else \i1;" & NL, + Inst); + when Id_Umul => + Disp_Template (" assign \o0 = \i0 * \i1; // umul" & NL, Inst); + when Id_Smul => + Disp_Template (" assign \o0 = \i0 * \i1; // smul" & NL, Inst); + when Id_Smod => + Disp_Template (" assign \o0 = \i0 % \i1; // smod" & NL, Inst); + when Id_Srem => + Disp_Template (" assign \o0 = \i0 % \i1; // srem" & NL, Inst); + when Id_Umod => + Disp_Template (" assign \o0 = \i0 % \i1; // umod" & NL, Inst); + when Id_Sdiv => + Disp_Template (" assign \o0 = \i0 / \i1; // sdiv" & NL, Inst); + when Id_Udiv => + Disp_Template (" assign \o0 = \i0 / \i1; // udiv" & NL, Inst); + when Id_Lsl => + Disp_Template (" assign \o0 = \i0 << \i1;" & NL, Inst); + when Id_Lsr => + Disp_Template (" assign \o0 = \i0 >> \i1;" & NL, Inst); + when Id_Asr => + Disp_Template (" assign \o0 = \si0 >> \i1;" & NL, Inst); + when Id_Rol => + Disp_Template + (" \o0 <= std_logic_vector " + & "(rotate_left (\ui0, to_integer (\ui1)));" & NL, Inst); + + when Id_Ult => + Disp_Template (" assign \o0 = \ui0 < \ui1;" & NL, Inst); + when Id_Ule => + Disp_Template (" assign \o0 = \ui0 <= \ui1;" & NL, Inst); + when Id_Ugt => + Disp_Template (" assign \o0 = \ui0 > \ui1;" & NL, Inst); + when Id_Uge => + Disp_Template (" assign \o0 = \ui0 >= \ui1;" & NL, Inst); + when Id_Slt => + Disp_Template (" assign \o0 = \si0 < \si1;" & NL, Inst); + when Id_Sle => + Disp_Template (" assign \o0 = \si0 <= \si1;" & NL, Inst); + when Id_Sgt => + Disp_Template (" assign \o0 = \si0 > \si1;" & NL, Inst); + when Id_Sge => + Disp_Template (" assign \o0 = \si0 >= \si1;" & NL, Inst); + when Id_Eq => + Disp_Template (" assign \o0 = \i0 == \i1;" & NL, Inst); + when Id_Ne => + Disp_Template (" assign \o0 = \i0 != \i1;" & NL, Inst); + when Id_Or => + Disp_Template (" assign \o0 = \i0 | \i1;" & NL, Inst); + when Id_And => + Disp_Template (" assign \o0 = \i0 & \i1;" & NL, Inst); + when Id_Xor => + Disp_Template (" assign \o0 = \i0 ^ \i1;" & NL, Inst); + when Id_Nor => + Disp_Template (" assign \o0 = ~(\i0 | \i1);" & NL, Inst); + when Id_Nand => + Disp_Template (" assign \o0 = ~(\i0 & \i1);" & NL, Inst); + when Id_Xnor => + Disp_Template (" assign \o0 = ~(\i0 ^ \i1);" & NL, Inst); + + when Id_Concat2 => + Disp_Template (" assign \o0 = {\i0, \i1};" & NL, Inst); + when Id_Concat3 => + Disp_Template (" assign \o0 = {\i0, \i1, \i2};" & NL, Inst); + when Id_Concat4 => + Disp_Template (" assign \o0 = {\i0, \i1, \i2, \i3};" & NL, Inst); + when Id_Concatn => + Disp_Template (" assign \o0 = {\i0", Inst); + for I in 1 .. Get_Nbr_Inputs (Inst) - 1 loop + Disp_Template (", ", Inst); + Disp_Net_Expr (Get_Input_Net (Inst, I), Inst, Conv_None); + end loop; + Disp_Template("};" & NL, Inst); + when Id_Utrunc + | Id_Strunc => + declare + W : constant Width := Get_Width (Get_Output (Inst, 0)); + begin + if W = 0 then + -- Do not try to slice the input, as it can be a single + -- wire. + Disp_Template (" assign \o0 = """"", Inst); + else + Disp_Template (" assign \o0 = \i0", Inst); + if W = 1 then + Disp_Template ("[0]", Inst); + else + Disp_Template ("[\n0:0]", Inst, (0 => W - 1)); + end if; + end if; + Disp_Template ("; // trunc" & NL, Inst); + end; + when Id_Uextend => + declare + Ow : constant Width := Get_Width (Get_Output (Inst, 0)); + Iw : constant Width := Get_Width (Get_Input_Net (Inst, 0)); + begin + pragma Assert (Ow > Iw); + Disp_Template (" assign \o0 = {", Inst); + Put_Uns32 (Ow - Iw); + Disp_Template ("'b0, \i0}; // uext" & NL, Inst); + end; + when Id_Sextend => + declare + Ow : constant Width := Get_Width (Get_Output (Inst, 0)); + Iw : constant Width := Get_Width (Get_Input_Net (Inst, 0)); + begin + pragma Assert (Ow > Iw); + Disp_Template (" assign \o0 = {{\n0{\i0", + Inst, (0 => Ow - Iw)); + if Iw > 1 then + Disp_Template ("[\n0]", Inst, (0 => Iw - 1)); + end if; + Disp_Template ("}}, \i0}; // sext" & NL, Inst); + end; + when Id_Red_Or => + Disp_Template (" assign \o0 = |(\i0);" & NL, Inst); + when Id_Red_And => + Disp_Template (" assign \o0 = &(\i0);" & NL, Inst); + when Id_Red_Xor => + Disp_Template (" assign \o0 = ^(\i0);" & NL, Inst); + + when Id_Posedge => + Disp_Template (" assign \o0 = 1'b0; // posedge" & NL, Inst); + when Id_Negedge => + Disp_Template (" assign \o0 = 1'b0; // negedge" & NL, Inst); + when Id_Tri => + Disp_Template (" assign \o0 = \i0 ? \i1 : \n0'bz;" & NL, + Inst, (0 => Get_Width (Get_Output (Inst, 0)))); + when Id_Assert => + Disp_Template + (" always @*" & NL & + " if (!\i0)" & NL & + " $fatal(1, ""assertion failure \l0"");" & NL, Inst); + when Id_Assume => + Disp_Template + (" \l0: assert \i0 = '1' severity warning; -- assume" & NL, + Inst); + when Id_Cover => + Disp_Template + (" \l0: assert \i0 = '1' severity note; -- cover" & NL, + Inst); + when Id_Assert_Cover => + Disp_Template + (" always @*" & NL & + " if (!\i0)" & NL & + " $fatal(1, ""assertion(cover) failure \l0"");" & NL, + Inst); + when Id_Resolver => + Disp_Template + (" assign \o0 = \i0;" & NL, Inst); + Disp_Template + (" assign \o0 = \i1;" & NL, Inst); + when others => + Disp_Instance_Gate (Inst); + end case; + end Disp_Instance_Inline; + + procedure Disp_Module_Declarations (M : Module) + is + Id : Module_Id; + begin + for Inst of Instances (M) loop + Id := Get_Id (Inst); + case Id is + when Id_Memory + | Id_Memory_Init => + -- For memories: skip the chain. + null; + when Id_Mem_Wr_Sync => + -- For memories: skip the chain. + null; + when Id_Mem_Rd + | Id_Mem_Rd_Sync => + -- For memories: skip the chain. + declare + N : constant Net := Get_Output (Inst, 1); + begin + if Id = Id_Mem_Rd_Sync then + Put (" reg "); + else + Put (" wire "); + end if; + Put_Type (Get_Width (N)); + Disp_Net_Name (N); + Put_Line ("; // mem_rd"); + end; + when others => + if Is_Self_Instance (Inst) + or else (Flag_Merge_Lit + and then Id in Constant_Module_Id + and then Id < Id_User_None + and then not Need_Signal (Inst)) + or else (Flag_Merge_Edge + and then Id in Edge_Module_Id + and then not Need_Edge (Inst)) + then + -- Not displayed. + null; + else + -- Check location is present. + if Locations.Get_Location (Inst) = No_Location then + case Id is + when Id_Const_UB32 + | Id_Const_SB32 + | Id_Const_UL32 + | Id_Const_Bit + | Id_Const_Log + | Id_Const_Z + | Id_Const_X + | Id_Const_0 + | Id_Concat2 + | Id_Concat3 + | Id_Concat4 + | Id_Concatn + | Id_Extract => + null; + when others => + raise Internal_Error; + end case; + end if; + + -- Display reg/wire for each output. + for N of Outputs (Inst) loop + case Id is + when Id_Dff + | Id_Idff + | Id_Adff + | Id_Iadff => + -- As expected + Put (" reg "); + when Id_Mux4 + | Id_Pmux + | Id_Dyn_Insert + | Id_Dyn_Insert_En => + -- Implemented by a process + Put (" reg "); + when Constant_Module_Id => + Put (" localparam "); + when others => + Put (" wire "); + end case; + Put_Type (Get_Width (N)); + Disp_Net_Name (N); + if Id in Constant_Module_Id then + Put (" = "); + Disp_Constant_Inline (Inst); + end if; + Put_Line (";"); + end loop; + end if; + end case; + end loop; + end Disp_Module_Declarations; + + procedure Disp_Module_Statements (M : Module) + is + Self_Inst : constant Instance := Get_Self_Instance (M); + begin + -- Output assignments. + declare + Idx : Port_Idx; + begin + Idx := 0; + for I of Inputs (Self_Inst) loop + Put (" assign "); + Put_Name (Get_Output_Desc (M, Idx).Name); + Put (" = "); + Disp_Net_Name (Get_Driver (I)); + Put_Line (";"); + Idx := Idx + 1; + end loop; + end; + + for Inst of Instances (M) loop + case Get_Id (Inst) is + when Constant_Module_Id => + if not Flag_Merge_Lit then + Disp_Instance_Inline (Inst); + end if; + when Edge_Module_Id => + if (not Flag_Merge_Edge) or else Need_Edge (Inst) then + Disp_Instance_Inline (Inst); + end if; + when others => + Disp_Instance_Inline (Inst); + end case; + end loop; + end Disp_Module_Statements; + + procedure Disp_Module_Port + (Desc : Port_Desc; Dir : Port_Kind; First : in out Boolean) is + begin + if First then + Put (" ("); + First := False; + else + Put_Line (","); + Put (" "); + end if; + case Dir is + when Port_In => + Put ("input "); + when Port_Out => + Put ("output "); + when Port_Inout => + Put ("inout "); + end case; + Put_Type (Desc.W); + Put_Name (Desc.Name); + end Disp_Module_Port; + + procedure Disp_Module_Ports (M : Module) + is + First : Boolean; + Desc : Port_Desc; + begin + First := True; + for I in 1 .. Get_Nbr_Inputs (M) loop + Disp_Module_Port (Get_Input_Desc (M, I - 1), Port_In, First); + end loop; + for I in 1 .. Get_Nbr_Outputs (M) loop + Desc := Get_Output_Desc (M, I - 1); + if Desc.Is_Inout then + Disp_Module_Port (Desc, Port_Inout, First); + else + Disp_Module_Port (Desc, Port_Out, First); + end if; + end loop; + if not First then + Put (")"); + end if; + Put_Line (";"); + end Disp_Module_Ports; + + procedure Disp_Module_Parameters (M : Module) + is + Nbr : constant Param_Nbr := Get_Nbr_Params (M); + Desc : Param_Desc; + begin + if Nbr = 0 then + return; + end if; + for I in 1 .. Nbr loop + if I = 1 then + Put_Line (" #("); + else + Put_Line (","); + end if; + Desc := Get_Param_Desc (M, I - 1); + Put (" "); + Put_Name (Desc.Name); + end loop; + Put_Line (")"); + end Disp_Module_Parameters; + + procedure Disp_Verilog_Module (M : Module) + is + Self_Inst : constant Instance := Get_Self_Instance (M); + begin + -- Module id and name. + Put ("module "); + Put_Name (Get_Module_Name (M)); + New_Line; + + Disp_Module_Parameters (M); + + Disp_Module_Ports (M); + + if Self_Inst /= No_Instance then + Disp_Module_Declarations (M); + Disp_Module_Statements (M); + end if; + Put_Line ("endmodule"); + New_Line; + end Disp_Verilog_Module; + + procedure Disp_Verilog (M : Module; Is_Top : Boolean) is + begin + -- Disp in reverse order. + declare + Num : Natural; + begin + Num := 0; + for S of Sub_Modules (M) loop + if Get_Id (S) >= Id_User_None then + Num := Num + 1; + end if; + end loop; + + declare + type Module_Array is array (1 .. Num) of Module; + Modules : Module_Array; + begin + Num := 0; + for S of Sub_Modules (M) loop + if Get_Id (S) >= Id_User_None then + Num := Num + 1; + Modules (Num) := S; + end if; + end loop; + + for I in reverse Modules'Range loop + Disp_Verilog (Modules (I), False); + end loop; + end; + end; + + if not Is_Top then + Disp_Verilog_Module (M); + end if; + end Disp_Verilog; + + procedure Disp_Verilog (M : Module) is + begin + Disp_Verilog (M, True); + end Disp_Verilog; +end Netlists.Disp_Verilog; diff --git a/src/synth/netlists-disp_verilog.ads b/src/synth/netlists-disp_verilog.ads new file mode 100644 index 000000000..0873c0eb9 --- /dev/null +++ b/src/synth/netlists-disp_verilog.ads @@ -0,0 +1,21 @@ +-- Disp a netlist in verilog. +-- Copyright (C) 2021 Tristan Gingold +-- +-- This file is part of GHDL. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 2 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see <gnu.org/licenses>. + +package Netlists.Disp_Verilog is + procedure Disp_Verilog (M : Module); +end Netlists.Disp_Verilog; diff --git a/src/synth/synth-environment.adb b/src/synth/synth-environment.adb index 001b417ca..9c9385dd4 100644 --- a/src/synth/synth-environment.adb +++ b/src/synth/synth-environment.adb @@ -69,6 +69,22 @@ package body Synth.Environment is Wire_Rec.Kind := Wire_None; end Free_Wire; + procedure Set_Kind (Wid : Wire_Id; Kind : Wire_Kind) + is + Wire_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid); + begin + pragma Assert (Kind = Wire_Unset or Wire_Rec.Kind = Wire_Unset); + Wire_Rec.Kind := Kind; + end Set_Kind; + + function Get_Kind (Wid : Wire_Id) return Wire_Kind + is + Wire_Rec : Wire_Id_Record renames Wire_Id_Table.Table (Wid); + begin + pragma Assert (Wire_Rec.Kind /= Wire_None); + return Wire_Rec.Kind; + end Get_Kind; + procedure Set_Wire_Gate (Wid : Wire_Id; Gate : Net) is begin -- Cannot override a gate. @@ -974,7 +990,7 @@ package body Synth.Environment is begin case Wid_Rec.Kind is when Wire_Signal | Wire_Output | Wire_Inout - | Wire_Variable => + | Wire_Variable | Wire_Unset => null; when Wire_Input | Wire_Enable | Wire_None => raise Internal_Error; @@ -1020,6 +1036,9 @@ package body Synth.Environment is | Wire_Enable => -- For signals, always read the previous value. return Wire_Rec.Gate; + when Wire_Unset => + pragma Assert (Wire_Rec.Cur_Assign = No_Seq_Assign); + return Wire_Rec.Gate; when Wire_None => raise Internal_Error; end case; diff --git a/src/synth/synth-environment.ads b/src/synth/synth-environment.ads index 70e472ac9..e06e254b2 100644 --- a/src/synth/synth-environment.ads +++ b/src/synth/synth-environment.ads @@ -78,6 +78,7 @@ package Synth.Environment is Wire_Variable, Wire_Enable, Wire_Signal, + Wire_Unset, Wire_Input, Wire_Output, Wire_Inout ); @@ -87,6 +88,11 @@ package Synth.Environment is -- Mark the wire as free. procedure Free_Wire (Wid : Wire_Id); + -- Change wire WID kind. + -- The only allowed transitions are Unset <-> (Variable or Signal). + procedure Set_Kind (Wid : Wire_Id; Kind : Wire_Kind); + function Get_Kind (Wid : Wire_Id) return Wire_Kind; + -- Read and write the mark flag. function Get_Wire_Mark (Wid : Wire_Id) return Boolean; procedure Set_Wire_Mark (Wid : Wire_Id; Mark : Boolean := True); diff --git a/src/synth/synth-static_oper.adb b/src/synth/synth-static_oper.adb index 5c9db02e9..2b9b5ffab 100644 --- a/src/synth/synth-static_oper.adb +++ b/src/synth/synth-static_oper.adb @@ -29,7 +29,7 @@ with Netlists; use Netlists; with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; with Synth.Source; use Synth.Source; -with Synth.Expr; use Synth.Expr; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Vhdl_Oper; with Synth.Ieee.Std_Logic_1164; use Synth.Ieee.Std_Logic_1164; with Synth.Ieee.Numeric_Std; use Synth.Ieee.Numeric_Std; diff --git a/src/synth/synth-vhdl_aggr.adb b/src/synth/synth-vhdl_aggr.adb index 250ebb1aa..fe7e95058 100644 --- a/src/synth/synth-vhdl_aggr.adb +++ b/src/synth/synth-vhdl_aggr.adb @@ -28,9 +28,9 @@ with Vhdl.Utils; use Vhdl.Utils; with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; -with Synth.Expr; use Synth.Expr; -with Synth.Stmts; use Synth.Stmts; -with Synth.Decls; use Synth.Decls; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; +with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; +with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; package body Synth.Vhdl_Aggr is type Stride_Array is array (Dim_Type range <>) of Nat32; diff --git a/src/synth/synth-vhdl_context.adb b/src/synth/synth-vhdl_context.adb index 0ef9b417e..bb3d7b98c 100644 --- a/src/synth/synth-vhdl_context.adb +++ b/src/synth/synth-vhdl_context.adb @@ -26,7 +26,7 @@ with Vhdl.Utils; with Netlists.Folds; use Netlists.Folds; -with Synth.Expr; use Synth.Expr; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Netlists.Locations; package body Synth.Vhdl_Context is diff --git a/src/synth/synth-decls.adb b/src/synth/synth-vhdl_decls.adb index a8f92c1f9..7507d21b0 100644 --- a/src/synth/synth-decls.adb +++ b/src/synth/synth-vhdl_decls.adb @@ -31,14 +31,14 @@ with Vhdl.Std_Package; with Vhdl.Ieee.Std_Logic_1164; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; -with Synth.Expr; use Synth.Expr; -with Synth.Stmts; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; +with Synth.Vhdl_Stmts; with Synth.Source; use Synth.Source; with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Files; with Synth.Values; use Synth.Values; -package body Synth.Decls is +package body Synth.Vhdl_Decls is procedure Create_Var_Wire (Syn_Inst : Synth_Instance_Acc; Decl : Iir; Init : Valtyp) is @@ -962,7 +962,7 @@ package body Synth.Decls is Ctxt : constant Context_Acc := Get_Build (Syn_Inst); Atype : constant Node := Get_Declaration_Type (Decl); Off : Value_Offsets; - Dyn : Stmts.Dyn_Name; + Dyn : Vhdl_Stmts.Dyn_Name; Res : Valtyp; Obj_Typ : Type_Acc; Base : Valtyp; @@ -976,8 +976,8 @@ package body Synth.Decls is Obj_Typ := null; end if; - Stmts.Synth_Assignment_Prefix (Syn_Inst, Get_Name (Decl), - Base, Typ, Off, Dyn); + Vhdl_Stmts.Synth_Assignment_Prefix (Syn_Inst, Get_Name (Decl), + Base, Typ, Off, Dyn); pragma Assert (Dyn.Voff = No_Net); if Base.Val.Kind = Value_Net then -- Object is a net if it is not writable. Extract the @@ -1224,4 +1224,4 @@ package body Synth.Decls is Decl := Get_Chain (Decl); end loop; end Finalize_Declarations; -end Synth.Decls; +end Synth.Vhdl_Decls; diff --git a/src/synth/synth-decls.ads b/src/synth/synth-vhdl_decls.ads index d227bdbe1..fa1569430 100644 --- a/src/synth/synth-decls.ads +++ b/src/synth/synth-vhdl_decls.ads @@ -22,7 +22,7 @@ with Netlists; use Netlists; with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Objtypes; use Synth.Objtypes; -package Synth.Decls is +package Synth.Vhdl_Decls is -- Return the Param_Type for ATYPE. function Type_To_Param_Type (Atype : Node) return Param_Type; @@ -76,4 +76,4 @@ package Synth.Decls is procedure Synth_Package_Instantiation (Parent_Inst : Synth_Instance_Acc; Pkg : Node); -end Synth.Decls; +end Synth.Vhdl_Decls; diff --git a/src/synth/synth-expr.adb b/src/synth/synth-vhdl_expr.adb index d05c0d089..9b2072865 100644 --- a/src/synth/synth-expr.adb +++ b/src/synth/synth-vhdl_expr.adb @@ -42,8 +42,8 @@ with Netlists.Locations; with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; with Synth.Vhdl_Environment; -with Synth.Decls; -with Synth.Stmts; use Synth.Stmts; +with Synth.Vhdl_Decls; +with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; with Synth.Vhdl_Oper; use Synth.Vhdl_Oper; with Synth.Vhdl_Heap; use Synth.Vhdl_Heap; with Synth.Debugger; @@ -52,7 +52,7 @@ with Synth.Vhdl_Aggr; with Grt.Types; with Grt.To_Strings; -package body Synth.Expr is +package body Synth.Vhdl_Expr is function Synth_Name (Syn_Inst : Synth_Instance_Acc; Name : Node) return Valtyp; @@ -537,7 +537,7 @@ package body Synth.Expr is when Iir_Kind_String_Literal8 => -- TODO: the value should be computed (once) and its type -- returned. - return Synth.Decls.Synth_Subtype_Indication + return Synth.Vhdl_Decls.Synth_Subtype_Indication (Syn_Inst, Get_Type (Expr)); when others => @@ -2498,7 +2498,7 @@ package body Synth.Expr is T : Type_Acc; Acc : Heap_Index; begin - T := Synth.Decls.Synth_Subtype_Indication + T := Synth.Vhdl_Decls.Synth_Subtype_Indication (Syn_Inst, Get_Subtype_Indication (Expr)); Acc := Allocate_By_Type (T); return Create_Value_Access (Acc, Expr_Type); @@ -2569,4 +2569,4 @@ package body Synth.Expr is (Syn_Inst, Get_Base_Type (Get_Type (Expr))); return Synth_Expression_With_Type (Syn_Inst, Expr, Basetype); end Synth_Expression_With_Basetype; -end Synth.Expr; +end Synth.Vhdl_Expr; diff --git a/src/synth/synth-expr.ads b/src/synth/synth-vhdl_expr.ads index 8dac335c4..c6726732e 100644 --- a/src/synth/synth-expr.ads +++ b/src/synth/synth-vhdl_expr.ads @@ -31,7 +31,7 @@ with Synth.Objtypes; use Synth.Objtypes; with Synth.Values; use Synth.Values; with Synth.Vhdl_Context; use Synth.Vhdl_Context; -package Synth.Expr is +package Synth.Vhdl_Expr is -- Perform a subtype conversion. Check constraints. function Synth_Subtype_Conversion (Ctxt : Context_Acc; Vt : Valtyp; @@ -149,4 +149,4 @@ package Synth.Expr is Vec : in out Logvec_Array; Vec_Off : in out Uns32; Has_Zx : in out Boolean); -end Synth.Expr; +end Synth.Vhdl_Expr; diff --git a/src/synth/synth-vhdl_files.adb b/src/synth/synth-vhdl_files.adb index 180062e01..2300ff9f9 100644 --- a/src/synth/synth-vhdl_files.adb +++ b/src/synth/synth-vhdl_files.adb @@ -26,7 +26,7 @@ with Grt.Stdio; with Synth.Memtype; use Synth.Memtype; with Synth.Objtypes; use Synth.Objtypes; -with Synth.Expr; use Synth.Expr; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Errors; use Synth.Errors; package body Synth.Vhdl_Files is diff --git a/src/synth/synth-insts.adb b/src/synth/synth-vhdl_insts.adb index ac37f8b0a..679b63312 100644 --- a/src/synth/synth-insts.adb +++ b/src/synth/synth-vhdl_insts.adb @@ -46,15 +46,15 @@ with Synth.Memtype; use Synth.Memtype; with Synth.Objtypes; use Synth.Objtypes; with Synth.Values; use Synth.Values; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; -with Synth.Stmts; use Synth.Stmts; -with Synth.Decls; use Synth.Decls; -with Synth.Expr; use Synth.Expr; +with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; +with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Source; use Synth.Source; with Synth.Debugger; with Synth.Vhdl_Files; with Synth.Errors; -package body Synth.Insts is +package body Synth.Vhdl_Insts is Root_Instance : Synth_Instance_Acc; function Mode_To_Port_Kind (Mode : Iir_Mode) return Port_Kind is @@ -364,7 +364,8 @@ package body Synth.Insts is begin case Get_Kind (Inter_Type) is when Iir_Kind_Array_Subtype_Definition => - if Synth.Decls.Has_Element_Subtype_Indication (Inter_Type) then + if Synth.Vhdl_Decls.Has_Element_Subtype_Indication (Inter_Type) + then Copy_Object_Subtype (Syn_Inst, Get_Element_Subtype (Inter_Type), Proto_Inst); end if; @@ -1748,4 +1749,4 @@ package body Synth.Insts is Idx := Idx + 1; end loop; end Synth_All_Instances; -end Synth.Insts; +end Synth.Vhdl_Insts; diff --git a/src/synth/synth-insts.ads b/src/synth/synth-vhdl_insts.ads index f0ac690e6..980b4ca8b 100644 --- a/src/synth/synth-insts.ads +++ b/src/synth/synth-vhdl_insts.ads @@ -21,7 +21,7 @@ with Vhdl.Nodes; use Vhdl.Nodes; with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Flags; use Synth.Flags; -package Synth.Insts is +package Synth.Vhdl_Insts is -- Create the declaration of the top entity. procedure Synth_Top_Entity (Global_Instance : Synth_Instance_Acc; Arch : Node; @@ -44,4 +44,4 @@ package Synth.Insts is procedure Synth_Component_Instantiation_Statement (Syn_Inst : Synth_Instance_Acc; Stmt : Node); -end Synth.Insts; +end Synth.Vhdl_Insts; diff --git a/src/synth/synth-vhdl_oper.adb b/src/synth/synth-vhdl_oper.adb index 2c3252a83..fadd500b5 100644 --- a/src/synth/synth-vhdl_oper.adb +++ b/src/synth/synth-vhdl_oper.adb @@ -34,8 +34,8 @@ with Netlists.Utils; with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; -with Synth.Stmts; use Synth.Stmts; -with Synth.Expr; use Synth.Expr; +with Synth.Vhdl_Stmts; use Synth.Vhdl_Stmts; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; with Synth.Source; with Synth.Static_Oper; use Synth.Static_Oper; diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-vhdl_stmts.adb index 8f33e3421..0f2694e06 100644 --- a/src/synth/synth-stmts.adb +++ b/src/synth/synth-vhdl_stmts.adb @@ -41,9 +41,9 @@ with PSL.NFAs; with Synth.Memtype; use Synth.Memtype; with Synth.Errors; use Synth.Errors; -with Synth.Decls; use Synth.Decls; -with Synth.Expr; use Synth.Expr; -with Synth.Insts; use Synth.Insts; +with Synth.Vhdl_Decls; use Synth.Vhdl_Decls; +with Synth.Vhdl_Expr; use Synth.Vhdl_Expr; +with Synth.Vhdl_Insts; use Synth.Vhdl_Insts; with Synth.Source; with Synth.Vhdl_Static_Proc; with Synth.Vhdl_Heap; @@ -56,7 +56,7 @@ with Netlists.Gates; use Netlists.Gates; with Netlists.Utils; use Netlists.Utils; with Netlists.Locations; use Netlists.Locations; -package body Synth.Stmts is +package body Synth.Vhdl_Stmts is procedure Synth_Sequential_Statements (C : in out Seq_Context; Stmts : Node); @@ -302,7 +302,7 @@ package body Synth.Stmts is if Is_Fully_Constrained_Type (Targ_Type) then -- If the aggregate subtype is known, just use it. - Bnd := Expr.Synth_Array_Bounds (Syn_Inst, Targ_Type, 1); + Bnd := Vhdl_Expr.Synth_Array_Bounds (Syn_Inst, Targ_Type, 1); else -- Ok, so the subtype of the aggregate is not known, in general -- because the length of an element is not known. That's with @@ -2006,7 +2006,8 @@ package body Synth.Stmts is (C.W_Ret, Build_Control_Signal (Sub_Inst, 1, Imp)); Phi_Assign_Static (C.W_Ret, Bit1); - Decls.Synth_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); + Vhdl_Decls.Synth_Declarations + (C.Inst, Get_Declaration_Chain (Bod), True); if not Is_Error (C.Inst) then Synth_Sequential_Statements (C, Get_Sequential_Statement_Chain (Bod)); end if; @@ -2031,7 +2032,8 @@ package body Synth.Stmts is Pop_Phi (Subprg_Phi); - Decls.Finalize_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); + Vhdl_Decls.Finalize_Declarations + (C.Inst, Get_Declaration_Chain (Bod), True); pragma Unreferenced (Infos); -- Propagate assignments. @@ -2106,7 +2108,8 @@ package body Synth.Stmts is end if; end if; - Decls.Finalize_Declarations (C.Inst, Get_Declaration_Chain (Bod), True); + Vhdl_Decls.Finalize_Declarations + (C.Inst, Get_Declaration_Chain (Bod), True); pragma Unreferenced (Infos); return Res; @@ -3850,4 +3853,4 @@ package body Synth.Stmts is Release (M, Proc_Pool); Instance_Pool := Prev_Instance_Pool; end Synth_Verification_Unit; -end Synth.Stmts; +end Synth.Vhdl_Stmts; diff --git a/src/synth/synth-stmts.ads b/src/synth/synth-vhdl_stmts.ads index 2009b1d4f..9621a7c9f 100644 --- a/src/synth/synth-stmts.ads +++ b/src/synth/synth-vhdl_stmts.ads @@ -26,7 +26,7 @@ with Synth.Values; use Synth.Values; with Synth.Vhdl_Context; use Synth.Vhdl_Context; with Synth.Vhdl_Environment; use Synth.Vhdl_Environment.Env; -package Synth.Stmts is +package Synth.Vhdl_Stmts is procedure Synth_Subprogram_Association (Subprg_Inst : Synth_Instance_Acc; Caller_Inst : Synth_Instance_Acc; Inter_Chain : Node; @@ -164,4 +164,4 @@ private S_En : Boolean; end case; end record; -end Synth.Stmts; +end Synth.Vhdl_Stmts; diff --git a/src/synth/synthesis.adb b/src/synth/synthesis.adb index 6e3dabfc0..131e6ba04 100644 --- a/src/synth/synthesis.adb +++ b/src/synth/synthesis.adb @@ -20,7 +20,7 @@ with Errorout; use Errorout; with Vhdl.Errors; use Vhdl.Errors; with Synth.Objtypes; -with Synth.Insts; use Synth.Insts; +with Synth.Vhdl_Insts; use Synth.Vhdl_Insts; with Synth.Values.Debug; pragma Unreferenced (Synth.Values.Debug); diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index 37ca1646b..5a412dd08 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -2864,6 +2864,7 @@ package body Trans.Chap4 is (El_List, Conv_Info.Instance_Field, Wki_Instance, Block_Info.Block_Decls_Ptr_Type); + -- Add instance field for the entity in case of direct instantiation. if Entity /= Null_Iir then Conv_Info.Instantiated_Entity := Entity; Entity_Info := Get_Info (Entity); @@ -3137,6 +3138,9 @@ package body Trans.Chap4 is end loop; end Translate_Association_Subprograms; + -- Register conversion CONV in association between SIG_IN and SIG_OUT. + -- This procedure allocates a record data (described by INFO), fill it + -- with addresses of signals and register it to REG_SUBPRG. procedure Elab_Conversion (Sig_In : Iir; Sig_Out : Iir; Conv : Iir; diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index f380efb07..02ed20f1e 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -302,6 +302,7 @@ package body Trans.Chap6 is Cond1, Cond2 : O_Enode; Cond : O_Enode; begin + -- FIXME: not correct for enumerations Cond1 := New_Compare_Op (ON_Lt, New_Obj_Value (Off), @@ -1133,7 +1134,8 @@ package body Trans.Chap6 is begin pragma Assert (Mode <= Name_Info.Alias_Kind); case Type_Info.Type_Mode is - when Type_Mode_Unbounded_Array => + when Type_Mode_Unbounded_Array + | Type_Mode_Unbounded_Record => return Get_Var (Name_Info.Alias_Var (Mode), Type_Info, Mode); when Type_Mode_Bounded_Arrays diff --git a/src/vhdl/vhdl-nodes.adb b/src/vhdl/vhdl-nodes.adb index 8acd7f6ac..b5dd5e0bd 100644 --- a/src/vhdl/vhdl-nodes.adb +++ b/src/vhdl/vhdl-nodes.adb @@ -5762,22 +5762,6 @@ package body Vhdl.Nodes is Set_Field4 (Name, Val); end Set_Named_Entity; - function Get_Alias_Declaration (Name : Iir) return Iir is - begin - pragma Assert (Name /= Null_Iir); - pragma Assert (Has_Alias_Declaration (Get_Kind (Name)), - "no field Alias_Declaration"); - return Get_Field2 (Name); - end Get_Alias_Declaration; - - procedure Set_Alias_Declaration (Name : Iir; Val : Iir) is - begin - pragma Assert (Name /= Null_Iir); - pragma Assert (Has_Alias_Declaration (Get_Kind (Name)), - "no field Alias_Declaration"); - Set_Field2 (Name, Val); - end Set_Alias_Declaration; - function Get_Referenced_Name (N : Iir) return Iir is begin pragma Assert (N /= Null_Iir); diff --git a/src/vhdl/vhdl-nodes.ads b/src/vhdl/vhdl-nodes.ads index 7d79ca43d..da01e6bc4 100644 --- a/src/vhdl/vhdl-nodes.ads +++ b/src/vhdl/vhdl-nodes.ads @@ -4310,8 +4310,6 @@ package Vhdl.Nodes is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Alias_Declaration (Field2) - -- -- Get/Set_Identifier (Field3) -- -- Get/Set_Named_Entity (Field4) @@ -4328,8 +4326,6 @@ package Vhdl.Nodes is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Alias_Declaration (Field2) - -- -- Get/Set_Identifier (Field3) -- -- Get/Set_Named_Entity (Field4) @@ -4346,8 +4342,6 @@ package Vhdl.Nodes is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Alias_Declaration (Field2) - -- -- Get/Set_Identifier (Field3) -- -- Get/Set_Named_Entity (Field4) @@ -4379,8 +4373,6 @@ package Vhdl.Nodes is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Alias_Declaration (Field2) - -- -- Get/Set_Identifier (Field3) -- -- Get/Set_Named_Entity (Field4) @@ -8788,12 +8780,6 @@ package Vhdl.Nodes is function Get_Named_Entity (Name : Iir) return Iir; procedure Set_Named_Entity (Name : Iir; Val : Iir); - -- If a name designate a non-object alias, the designated alias. - -- Named_Entity will designate the aliased entity. - -- Field: Field2 Ref - function Get_Alias_Declaration (Name : Iir) return Iir; - procedure Set_Alias_Declaration (Name : Iir; Val : Iir); - -- Field: Field2 Ref function Get_Referenced_Name (N : Iir) return Iir; procedure Set_Referenced_Name (N : Iir; Name : Iir); diff --git a/src/vhdl/vhdl-nodes_meta.adb b/src/vhdl/vhdl-nodes_meta.adb index bd85e083c..91f764376 100644 --- a/src/vhdl/vhdl-nodes_meta.adb +++ b/src/vhdl/vhdl-nodes_meta.adb @@ -289,7 +289,6 @@ package body Vhdl.Nodes_Meta is Field_Default_Entity_Aspect => Type_Iir, Field_Binding_Indication => Type_Iir, Field_Named_Entity => Type_Iir, - Field_Alias_Declaration => Type_Iir, Field_Referenced_Name => Type_Iir, Field_Expr_Staticness => Type_Iir_Staticness, Field_Scalar_Size => Type_Scalar_Size, @@ -942,8 +941,6 @@ package body Vhdl.Nodes_Meta is return "binding_indication"; when Field_Named_Entity => return "named_entity"; - when Field_Alias_Declaration => - return "alias_declaration"; when Field_Referenced_Name => return "referenced_name"; when Field_Expr_Staticness => @@ -2332,8 +2329,6 @@ package body Vhdl.Nodes_Meta is return Attr_Maybe_Ref; when Field_Named_Entity => return Attr_Maybe_Forward_Ref; - when Field_Alias_Declaration => - return Attr_Ref; when Field_Referenced_Name => return Attr_Ref; when Field_Expr_Staticness => @@ -4767,7 +4762,6 @@ package body Vhdl.Nodes_Meta is Field_Expr_Staticness, Field_Name_Staticness, Field_Type, - Field_Alias_Declaration, Field_Named_Entity, Field_Base_Name, -- Iir_Kind_Simple_Name @@ -4776,7 +4770,6 @@ package body Vhdl.Nodes_Meta is Field_Expr_Staticness, Field_Name_Staticness, Field_Type, - Field_Alias_Declaration, Field_Named_Entity, Field_Base_Name, -- Iir_Kind_Selected_Name @@ -4786,14 +4779,12 @@ package body Vhdl.Nodes_Meta is Field_Name_Staticness, Field_Prefix, Field_Type, - Field_Alias_Declaration, Field_Named_Entity, Field_Base_Name, -- Iir_Kind_Operator_Symbol Field_Identifier, Field_Is_Forward_Ref, Field_Type, - Field_Alias_Declaration, Field_Named_Entity, Field_Base_Name, -- Iir_Kind_Reference_Name @@ -5494,74 +5485,74 @@ package body Vhdl.Nodes_Meta is Iir_Kind_Break_Statement => 1959, Iir_Kind_If_Statement => 1969, Iir_Kind_Elsif => 1975, - Iir_Kind_Character_Literal => 1983, - Iir_Kind_Simple_Name => 1991, - Iir_Kind_Selected_Name => 2000, - Iir_Kind_Operator_Symbol => 2006, - Iir_Kind_Reference_Name => 2011, - Iir_Kind_External_Constant_Name => 2020, - Iir_Kind_External_Signal_Name => 2029, - Iir_Kind_External_Variable_Name => 2039, - Iir_Kind_Selected_By_All_Name => 2045, - Iir_Kind_Parenthesis_Name => 2050, - Iir_Kind_Package_Pathname => 2054, - Iir_Kind_Absolute_Pathname => 2055, - Iir_Kind_Relative_Pathname => 2056, - Iir_Kind_Pathname_Element => 2061, - Iir_Kind_Base_Attribute => 2063, - Iir_Kind_Subtype_Attribute => 2068, - Iir_Kind_Element_Attribute => 2073, - Iir_Kind_Across_Attribute => 2078, - Iir_Kind_Through_Attribute => 2083, - Iir_Kind_Nature_Reference_Attribute => 2087, - Iir_Kind_Left_Type_Attribute => 2092, - Iir_Kind_Right_Type_Attribute => 2097, - Iir_Kind_High_Type_Attribute => 2102, - Iir_Kind_Low_Type_Attribute => 2107, - Iir_Kind_Ascending_Type_Attribute => 2112, - Iir_Kind_Image_Attribute => 2118, - Iir_Kind_Value_Attribute => 2124, - Iir_Kind_Pos_Attribute => 2130, - Iir_Kind_Val_Attribute => 2136, - Iir_Kind_Succ_Attribute => 2142, - Iir_Kind_Pred_Attribute => 2148, - Iir_Kind_Leftof_Attribute => 2154, - Iir_Kind_Rightof_Attribute => 2160, - Iir_Kind_Signal_Slew_Attribute => 2168, - Iir_Kind_Quantity_Slew_Attribute => 2176, - Iir_Kind_Ramp_Attribute => 2184, - Iir_Kind_Zoh_Attribute => 2192, - Iir_Kind_Ltf_Attribute => 2200, - Iir_Kind_Ztf_Attribute => 2210, - Iir_Kind_Dot_Attribute => 2217, - Iir_Kind_Integ_Attribute => 2224, - Iir_Kind_Above_Attribute => 2232, - Iir_Kind_Quantity_Delayed_Attribute => 2240, - Iir_Kind_Delayed_Attribute => 2249, - Iir_Kind_Stable_Attribute => 2258, - Iir_Kind_Quiet_Attribute => 2267, - Iir_Kind_Transaction_Attribute => 2276, - Iir_Kind_Event_Attribute => 2280, - Iir_Kind_Active_Attribute => 2284, - Iir_Kind_Last_Event_Attribute => 2288, - Iir_Kind_Last_Active_Attribute => 2292, - Iir_Kind_Last_Value_Attribute => 2296, - Iir_Kind_Driving_Attribute => 2300, - Iir_Kind_Driving_Value_Attribute => 2304, - Iir_Kind_Behavior_Attribute => 2304, - Iir_Kind_Structure_Attribute => 2304, - Iir_Kind_Simple_Name_Attribute => 2311, - Iir_Kind_Instance_Name_Attribute => 2316, - Iir_Kind_Path_Name_Attribute => 2321, - Iir_Kind_Left_Array_Attribute => 2328, - Iir_Kind_Right_Array_Attribute => 2335, - Iir_Kind_High_Array_Attribute => 2342, - Iir_Kind_Low_Array_Attribute => 2349, - Iir_Kind_Length_Array_Attribute => 2356, - Iir_Kind_Ascending_Array_Attribute => 2363, - Iir_Kind_Range_Array_Attribute => 2370, - Iir_Kind_Reverse_Range_Array_Attribute => 2377, - Iir_Kind_Attribute_Name => 2386 + Iir_Kind_Character_Literal => 1982, + Iir_Kind_Simple_Name => 1989, + Iir_Kind_Selected_Name => 1997, + Iir_Kind_Operator_Symbol => 2002, + Iir_Kind_Reference_Name => 2007, + Iir_Kind_External_Constant_Name => 2016, + Iir_Kind_External_Signal_Name => 2025, + Iir_Kind_External_Variable_Name => 2035, + Iir_Kind_Selected_By_All_Name => 2041, + Iir_Kind_Parenthesis_Name => 2046, + Iir_Kind_Package_Pathname => 2050, + Iir_Kind_Absolute_Pathname => 2051, + Iir_Kind_Relative_Pathname => 2052, + Iir_Kind_Pathname_Element => 2057, + Iir_Kind_Base_Attribute => 2059, + Iir_Kind_Subtype_Attribute => 2064, + Iir_Kind_Element_Attribute => 2069, + Iir_Kind_Across_Attribute => 2074, + Iir_Kind_Through_Attribute => 2079, + Iir_Kind_Nature_Reference_Attribute => 2083, + Iir_Kind_Left_Type_Attribute => 2088, + Iir_Kind_Right_Type_Attribute => 2093, + Iir_Kind_High_Type_Attribute => 2098, + Iir_Kind_Low_Type_Attribute => 2103, + Iir_Kind_Ascending_Type_Attribute => 2108, + Iir_Kind_Image_Attribute => 2114, + Iir_Kind_Value_Attribute => 2120, + Iir_Kind_Pos_Attribute => 2126, + Iir_Kind_Val_Attribute => 2132, + Iir_Kind_Succ_Attribute => 2138, + Iir_Kind_Pred_Attribute => 2144, + Iir_Kind_Leftof_Attribute => 2150, + Iir_Kind_Rightof_Attribute => 2156, + Iir_Kind_Signal_Slew_Attribute => 2164, + Iir_Kind_Quantity_Slew_Attribute => 2172, + Iir_Kind_Ramp_Attribute => 2180, + Iir_Kind_Zoh_Attribute => 2188, + Iir_Kind_Ltf_Attribute => 2196, + Iir_Kind_Ztf_Attribute => 2206, + Iir_Kind_Dot_Attribute => 2213, + Iir_Kind_Integ_Attribute => 2220, + Iir_Kind_Above_Attribute => 2228, + Iir_Kind_Quantity_Delayed_Attribute => 2236, + Iir_Kind_Delayed_Attribute => 2245, + Iir_Kind_Stable_Attribute => 2254, + Iir_Kind_Quiet_Attribute => 2263, + Iir_Kind_Transaction_Attribute => 2272, + Iir_Kind_Event_Attribute => 2276, + Iir_Kind_Active_Attribute => 2280, + Iir_Kind_Last_Event_Attribute => 2284, + Iir_Kind_Last_Active_Attribute => 2288, + Iir_Kind_Last_Value_Attribute => 2292, + Iir_Kind_Driving_Attribute => 2296, + Iir_Kind_Driving_Value_Attribute => 2300, + Iir_Kind_Behavior_Attribute => 2300, + Iir_Kind_Structure_Attribute => 2300, + Iir_Kind_Simple_Name_Attribute => 2307, + Iir_Kind_Instance_Name_Attribute => 2312, + Iir_Kind_Path_Name_Attribute => 2317, + Iir_Kind_Left_Array_Attribute => 2324, + Iir_Kind_Right_Array_Attribute => 2331, + Iir_Kind_High_Array_Attribute => 2338, + Iir_Kind_Low_Array_Attribute => 2345, + Iir_Kind_Length_Array_Attribute => 2352, + Iir_Kind_Ascending_Array_Attribute => 2359, + Iir_Kind_Range_Array_Attribute => 2366, + Iir_Kind_Reverse_Range_Array_Attribute => 2373, + Iir_Kind_Attribute_Name => 2382 ); function Get_Fields_First (K : Iir_Kind) return Fields_Index is @@ -6360,8 +6351,6 @@ package body Vhdl.Nodes_Meta is return Get_Binding_Indication (N); when Field_Named_Entity => return Get_Named_Entity (N); - when Field_Alias_Declaration => - return Get_Alias_Declaration (N); when Field_Referenced_Name => return Get_Referenced_Name (N); when Field_Error_Origin => @@ -6818,8 +6807,6 @@ package body Vhdl.Nodes_Meta is Set_Binding_Indication (N, V); when Field_Named_Entity => Set_Named_Entity (N, V); - when Field_Alias_Declaration => - Set_Alias_Declaration (N, V); when Field_Referenced_Name => Set_Referenced_Name (N, V); when Field_Error_Origin => @@ -11124,19 +11111,6 @@ package body Vhdl.Nodes_Meta is end case; end Has_Named_Entity; - function Has_Alias_Declaration (K : Iir_Kind) return Boolean is - begin - case K is - when Iir_Kind_Character_Literal - | Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name - | Iir_Kind_Operator_Symbol => - return True; - when others => - return False; - end case; - end Has_Alias_Declaration; - function Has_Referenced_Name (K : Iir_Kind) return Boolean is begin return K = Iir_Kind_Reference_Name; diff --git a/src/vhdl/vhdl-nodes_meta.ads b/src/vhdl/vhdl-nodes_meta.ads index 65ace54bb..0585fbe93 100644 --- a/src/vhdl/vhdl-nodes_meta.ads +++ b/src/vhdl/vhdl-nodes_meta.ads @@ -333,7 +333,6 @@ package Vhdl.Nodes_Meta is Field_Default_Entity_Aspect, Field_Binding_Indication, Field_Named_Entity, - Field_Alias_Declaration, Field_Referenced_Name, Field_Expr_Staticness, Field_Scalar_Size, @@ -922,7 +921,6 @@ package Vhdl.Nodes_Meta is function Has_Default_Entity_Aspect (K : Iir_Kind) return Boolean; function Has_Binding_Indication (K : Iir_Kind) return Boolean; function Has_Named_Entity (K : Iir_Kind) return Boolean; - function Has_Alias_Declaration (K : Iir_Kind) return Boolean; function Has_Referenced_Name (K : Iir_Kind) return Boolean; function Has_Expr_Staticness (K : Iir_Kind) return Boolean; function Has_Scalar_Size (K : Iir_Kind) return Boolean; diff --git a/src/vhdl/vhdl-sem.adb b/src/vhdl/vhdl-sem.adb index 663adac7b..06b6fbced 100644 --- a/src/vhdl/vhdl-sem.adb +++ b/src/vhdl/vhdl-sem.adb @@ -1367,6 +1367,21 @@ package body Vhdl.Sem is end loop; end Are_Trees_Chain_Equal; + function Are_Trees_List_Equal (Left, Right : Iir_Flist) return Boolean + is + El_Left, El_Right : Iir; + begin + pragma Assert (Flist_Last (Left) = Flist_Last (Right)); + for I in Flist_First .. Flist_Last (Left) loop + El_Left := Get_Nth_Element (Left, I); + El_Right := Get_Nth_Element (Right, I); + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + end loop; + return True; + end Are_Trees_List_Equal; + -- Return TRUE iff LEFT and RIGHT are (in depth) equal. -- This corresponds to conformance rules, LRM93 2.7 function Are_Trees_Equal (Left, Right : Iir) return Boolean @@ -1489,46 +1504,21 @@ package body Vhdl.Sem is then return False; end if; - declare - L_Left : constant Iir_Flist := Get_Index_Subtype_List (Left); - L_Right : constant Iir_Flist := Get_Index_Subtype_List (Right); - begin - if Get_Nbr_Elements (L_Left) /= Get_Nbr_Elements (L_Right) then - return False; - end if; - for I in Flist_First .. Flist_Last (L_Left) loop - El_Left := Get_Nth_Element (L_Left, I); - El_Right := Get_Nth_Element (L_Right, I); - if not Are_Trees_Equal (El_Left, El_Right) then - return False; - end if; - end loop; - end; + if not Are_Trees_List_Equal (Get_Index_Subtype_List (Left), + Get_Index_Subtype_List (Right)) + then + return False; + end if; return True; when Iir_Kind_Record_Subtype_Definition => if Get_Base_Type (Left) /= Get_Base_Type (Right) then return False; end if; - if not Are_Trees_Equal (Get_Resolution_Indication (Left), + return Are_Trees_Equal (Get_Resolution_Indication (Left), Get_Resolution_Indication (Right)) - then - return False; - end if; - declare - L_Left : constant Iir_Flist := - Get_Elements_Declaration_List (Left); - L_Right : constant Iir_Flist := - Get_Elements_Declaration_List (Right); - begin - for I in Flist_First .. Flist_Last (L_Left) loop - El_Left := Get_Nth_Element (L_Left, I); - El_Right := Get_Nth_Element (L_Right, I); - if not Are_Trees_Equal (El_Left, El_Right) then - return False; - end if; - end loop; - end; - return True; + and then + Are_Trees_List_Equal (Get_Elements_Declaration_List (Left), + Get_Elements_Declaration_List (Right)); when Iir_Kind_Integer_Literal => if Get_Value (Left) /= Get_Value (Right) then @@ -1596,6 +1586,18 @@ package body Vhdl.Sem is Are_Trees_Equal (Get_Expression (Left), Get_Expression (Right)); + when Iir_Kind_Indexed_Name => + return Are_Trees_Equal (Get_Prefix (Left), + Get_Prefix (Right)) + and then + Are_Trees_List_Equal (Get_Index_List (Left), + Get_Index_List (Right)); + when Iir_Kind_Slice_Name => + return Are_Trees_Equal (Get_Prefix (Left), + Get_Prefix (Right)) + and then Are_Trees_Equal (Get_Suffix (Left), + Get_Suffix (Right)); + when Iir_Kind_Access_Type_Definition | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition @@ -1609,14 +1611,10 @@ package body Vhdl.Sem is then return False; end if; - if not Are_Trees_Equal (Get_Left_Limit (Left), + return Are_Trees_Equal (Get_Left_Limit (Left), Get_Left_Limit (Right)) - or else not Are_Trees_Equal (Get_Right_Limit (Left), - Get_Right_Limit (Right)) - then - return False; - end if; - return True; + and then Are_Trees_Equal (Get_Right_Limit (Left), + Get_Right_Limit (Right)); when Iir_Kind_High_Type_Attribute | Iir_Kind_Low_Type_Attribute @@ -1661,21 +1659,9 @@ package body Vhdl.Sem is if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then return False; end if; - declare - El_L, El_R : Iir; - begin - El_L := Get_Association_Choices_Chain (Left); - El_R := Get_Association_Choices_Chain (Right); - loop - exit when El_L = Null_Iir and El_R = Null_Iir; - if not Are_Trees_Equal (El_L, El_R) then - return False; - end if; - El_L := Get_Chain (El_L); - El_R := Get_Chain (El_R); - end loop; - return True; - end; + return Are_Trees_Chain_Equal + (Get_Association_Choices_Chain (Left), + Get_Association_Choices_Chain (Right)); when Iir_Kind_Choice_By_None | Iir_Kind_Choice_By_Others => diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb index ab4451d77..1ed7c7b64 100644 --- a/src/vhdl/vhdl-sem_names.adb +++ b/src/vhdl/vhdl-sem_names.adb @@ -2152,7 +2152,6 @@ package body Vhdl.Sem_Names is if not Keep_Alias and then Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration then - Set_Alias_Declaration (Name, Res); Res := Get_Named_Entity (Get_Name (Res)); end if; else diff --git a/src/vhdl/vhdl-sem_stmts.adb b/src/vhdl/vhdl-sem_stmts.adb index b0b0447da..b52476f9b 100644 --- a/src/vhdl/vhdl-sem_stmts.adb +++ b/src/vhdl/vhdl-sem_stmts.adb @@ -879,6 +879,7 @@ package body Vhdl.Sem_Stmts is Target : Iir; Target_Type : Iir; Target_Object : Iir; + Target_Prefix : Iir; Expr : Iir; Constrained : Boolean; begin @@ -894,6 +895,7 @@ package body Vhdl.Sem_Stmts is Target := Sem_Expression_Wildcard (Target, Wildcard_Any_Type); Target_Object := Null_Iir; + Target_Prefix := Null_Iir; Target_Type := Wildcard_Any_Type; if Target = Null_Iir then -- To avoid spurious errors, assume the target is fully @@ -905,21 +907,22 @@ package body Vhdl.Sem_Stmts is Check_Target (Stmt, Target); Target_Type := Get_Type (Target); Target_Object := Check_Simple_Signal_Target_Object (Target); + Target_Prefix := Get_Object_Prefix (Target_Object); Constrained := Is_Object_Name_Fully_Constrained (Target_Object); else Constrained := False; end if; end if; - if Target_Object /= Null_Iir then + if Target_Prefix /= Null_Iir then -- LRM08 10.5.2 Simple signal assignments -- If the right-hand side of a simple force assignment or a simple -- release assignment does not specify a force mode, then a default -- force mode is used as follow: if not Get_Has_Force_Mode (Stmt) then - case Get_Kind (Target_Object) is + case Get_Kind (Target_Prefix) is when Iir_Kind_Interface_Signal_Declaration => - case Get_Mode (Target_Object) is + case Get_Mode (Target_Prefix) is when Iir_In_Mode => -- - If the target is a port or signal parameter of -- mode IN, a force mode IN is used. @@ -950,10 +953,10 @@ package body Vhdl.Sem_Stmts is else -- It is an error if a force mode of OUT is specified and the -- target is a port of mode IN. - case Get_Kind (Target_Object) is + case Get_Kind (Target_Prefix) is when Iir_Kind_Interface_Signal_Declaration => if Get_Force_Mode (Stmt) = Iir_Force_Out - and then Get_Mode (Target_Object) = Iir_In_Mode + and then Get_Mode (Target_Prefix) = Iir_In_Mode then Error_Msg_Sem (+Stmt, "cannot use force OUT for IN port %n", diff --git a/src/vhdl/vhdl-utils.adb b/src/vhdl/vhdl-utils.adb index 578576e1e..46c9bcd72 100644 --- a/src/vhdl/vhdl-utils.adb +++ b/src/vhdl/vhdl-utils.adb @@ -1088,11 +1088,16 @@ package body Vhdl.Utils is | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_Signal_Declaration | Iir_Kind_Object_Alias_Declaration => - if (Get_Kind (Get_Subtype_Indication (Base)) - = Iir_Kind_Subtype_Attribute) - then - return True; - end if; + declare + Ind : constant Iir := Get_Subtype_Indication (Base); + begin + -- Note: an object alias may not have subtype indication. + if Ind /= Null_Iir + and then Get_Kind (Ind) = Iir_Kind_Subtype_Attribute + then + return True; + end if; + end; when Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference => null; |