diff options
author | Tristan Gingold <tgingold@free.fr> | 2015-01-07 08:07:42 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2015-01-07 08:07:42 +0100 |
commit | 99443212bf78a5d36b693abab225a160a92d097a (patch) | |
tree | 9191d2419b376bd45737e3b23e9b95967c017560 | |
parent | 3aaf2679a61b4d8bd61c7cccd5ca0ec1f1606de5 (diff) | |
download | ghdl-99443212bf78a5d36b693abab225a160a92d097a.tar.gz ghdl-99443212bf78a5d36b693abab225a160a92d097a.tar.bz2 ghdl-99443212bf78a5d36b693abab225a160a92d097a.zip |
Handle vhdl08 if generate statements
-rw-r--r-- | src/grt/grt-avhpi.adb | 21 | ||||
-rw-r--r-- | src/grt/grt-disp_rti.adb | 53 | ||||
-rw-r--r-- | src/grt/grt-disp_tree.adb | 14 | ||||
-rw-r--r-- | src/grt/grt-rtis_addr.adb | 19 | ||||
-rw-r--r-- | src/grt/grt-rtis_addr.ads | 5 | ||||
-rw-r--r-- | src/grt/grt-rtis_utils.adb | 58 | ||||
-rw-r--r-- | src/vhdl/canon.adb | 23 | ||||
-rw-r--r-- | src/vhdl/parse.adb | 135 | ||||
-rw-r--r-- | src/vhdl/sem_stmts.adb | 41 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap1.adb | 40 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap9.adb | 426 | ||||
-rw-r--r-- | src/vhdl/translate/trans-rtis.adb | 488 | ||||
-rw-r--r-- | src/vhdl/translate/trans.ads | 23 |
13 files changed, 847 insertions, 499 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index f6c5c4138..1b8e5aa76 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -297,20 +297,13 @@ package body Grt.Avhpi is Error := AvhpiErrorOk; return; when Ghdl_Rtik_If_Generate => - declare - Gen : constant Ghdl_Rtin_Generate_Acc := - To_Ghdl_Rtin_Generate_Acc (Ch); - begin - Res := (Kind => VhpiIfGenerateK, - Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base - + Gen.Loc).all, - Block => Gen.Child)); - -- Return only if the condition is true. - if Res.Ctxt.Base /= Null_Address then - Error := AvhpiErrorOk; - return; - end if; - end; + Res := (Kind => VhpiIfGenerateK, + Ctxt => Get_If_Generate_Child (Iterator.Ctxt, Ch)); + -- Return only if the condition is true. + if Res.Ctxt.Base /= Null_Address then + Error := AvhpiErrorOk; + return; + end if; when Ghdl_Rtik_For_Generate => declare Gen : constant Ghdl_Rtin_Generate_Acc := diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb index 1e029d151..ad45d087a 100644 --- a/src/grt/grt-disp_rti.adb +++ b/src/grt/grt-disp_rti.adb @@ -702,16 +702,21 @@ package body Grt.Disp_Rti is when Ghdl_Rtik_Generate_Body => Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, Ctxt, Indent + 1); + when Ghdl_Rtik_If_Generate => + Nctxt := Get_If_Generate_Child (Ctxt, To_Ghdl_Rti_Access (Blk)); + Disp_Block + (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt, Indent + 1); when others => Internal_Error ("disp_block"); end case; end Disp_Block; - procedure Disp_Generate (Gen : Ghdl_Rtin_Generate_Acc; - Ctxt : Rti_Context; - Indent : Natural) + procedure Disp_For_Generate (Gen : Ghdl_Rtin_Generate_Acc; + Ctxt : Rti_Context; + Indent : Natural) is Nctxt : Rti_Context; + Length : Ghdl_Index_Type; begin Disp_Indent (Indent); Disp_Kind (Gen.Common.Kind); @@ -721,31 +726,16 @@ package body Grt.Disp_Rti is Put (": "); Disp_Name (Gen.Name); New_Line; - case Gen.Common.Kind is - when Ghdl_Rtik_For_Generate => - declare - Length : Ghdl_Index_Type; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, - Block => Gen.Child); - Length := Get_For_Generate_Length (Gen, Ctxt); - for I in 1 .. Length loop - Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child), - Nctxt, Indent + 1); - Nctxt.Base := Nctxt.Base + Gen.Size; - end loop; - end; - when Ghdl_Rtik_If_Generate => - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, - Block => Gen.Child); - if Nctxt.Base /= Null_Address then - Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child), - Nctxt, Indent + 1); - end if; - when others => - Internal_Error ("disp_generate"); - end case; - end Disp_Generate; + + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, + Block => Gen.Child); + Length := Get_For_Generate_Length (Gen, Ctxt); + for I in 1 .. Length loop + Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child), + Nctxt, Indent + 1); + Nctxt.Base := Nctxt.Base + Gen.Size; + end loop; + end Disp_For_Generate; procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; Is_Sig : Boolean; @@ -1083,9 +1073,10 @@ package body Grt.Disp_Rti is | Ghdl_Rtik_Process | Ghdl_Rtik_Block => Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_If_Generate - | Ghdl_Rtik_For_Generate => - Disp_Generate (To_Ghdl_Rtin_Generate_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_If_Generate => + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_For_Generate => + Disp_For_Generate (To_Ghdl_Rtin_Generate_Acc (Rti), Ctxt, Indent); when Ghdl_Rtik_Package_Body => Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); diff --git a/src/grt/grt-disp_tree.adb b/src/grt/grt-disp_tree.adb index 4afb64191..3eb715d3f 100644 --- a/src/grt/grt-disp_tree.adb +++ b/src/grt/grt-disp_tree.adb @@ -154,10 +154,11 @@ package body Grt.Disp_Tree is when Ghdl_Rtik_If_Generate => Put (" [if-generate "); if Ctxt.Base = Null_Address then - Put ("false]"); + Put ("false"); else - Put ("true]"); + Put ("true"); end if; + Put ("]"); when Ghdl_Rtik_Signal => Put (" [signal]"); when Ghdl_Rtik_Port => @@ -282,16 +283,13 @@ package body Grt.Disp_Tree is end; when Ghdl_Rtik_If_Generate => declare - Gen : constant Ghdl_Rtin_Generate_Acc := - To_Ghdl_Rtin_Generate_Acc (Child); - Nctxt : Rti_Context; + Nctxt : constant Rti_Context := + Get_If_Generate_Child (Ctxt, Child); begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, - Block => Gen.Child); Disp_Header (Nctxt); if Nctxt.Base /= Null_Address then Disp_Sub_Block - (To_Ghdl_Rtin_Block_Acc (Gen.Child), Nctxt); + (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt); end if; end; when Ghdl_Rtik_Instance => diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb index 199c449eb..444f1f033 100644 --- a/src/grt/grt-rtis_addr.adb +++ b/src/grt/grt-rtis_addr.adb @@ -135,6 +135,25 @@ package body Grt.Rtis_Addr is end if; end Get_Instance_Link; + function Get_If_Generate_Child (Ctxt : Rti_Context; Gen : Ghdl_Rti_Access) + return Rti_Context + is + pragma Assert (Gen.Kind = Ghdl_Rtik_If_Generate); + Blk : constant Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Gen); + Base_Addr : constant Address := Ctxt.Base + Blk.Loc; + + -- Address of the block_id field. It is just after the instance field. + -- Assume alignment is ok (it is on 32 and 64 bit platforms). + Id_Addr : constant Address := + Base_Addr + Ghdl_Index_Type'(Address'Size / Storage_Unit); + Id : Ghdl_Index_Type; + pragma Import (Ada, Id); + for Id'Address use Id_Addr; + begin + return (Base => To_Addr_Acc (Base_Addr).all, + Block => Blk.Children (Id)); + end Get_If_Generate_Child; + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; Loc : Ghdl_Rti_Loc; Ctxt : Rti_Context) diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads index 5dd070334..dd0ca1546 100644 --- a/src/grt/grt-rtis_addr.ads +++ b/src/grt/grt-rtis_addr.ads @@ -64,6 +64,11 @@ package Grt.Rtis_Addr is Ctxt : out Rti_Context; Stmt : out Ghdl_Rti_Access); + -- Get the child context of if-generate statement GEN. Return Null_Context + -- if there is no child. + function Get_If_Generate_Child (Ctxt : Rti_Context; Gen : Ghdl_Rti_Access) + return Rti_Context; + -- Convert a location to an address. function Loc_To_Addr (Depth : Ghdl_Rti_Depth; Loc : Ghdl_Rti_Loc; diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb index 1994e90cb..9d7a56f2f 100644 --- a/src/grt/grt-rtis_utils.adb +++ b/src/grt/grt-rtis_utils.adb @@ -77,16 +77,10 @@ package body Grt.Rtis_Utils is end loop; end; when Ghdl_Rtik_If_Generate => - declare - Gen : constant Ghdl_Rtin_Generate_Acc := - To_Ghdl_Rtin_Generate_Acc (Child); - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, - Block => Gen.Child); - if Nctxt.Base /= Null_Address then - Res := Traverse_Blocks_1 (Nctxt); - end if; - end; + Nctxt := Get_If_Generate_Child (Ctxt, Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; when Ghdl_Rtik_Instance => Res := Process (Ctxt, Child); if Res = Traverse_Ok then @@ -567,12 +561,6 @@ package body Grt.Rtis_Utils is loop Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); case Ctxt.Block.Kind is - when Ghdl_Rtik_Process - | Ghdl_Rtik_Block - | Ghdl_Rtik_If_Generate => - Prepend (Rstr, Blk.Name); - Prepend (Rstr, Sep); - Ctxt := Get_Parent_Context (Ctxt); when Ghdl_Rtik_Entity => declare Link : Ghdl_Entity_Link_Acc; @@ -626,20 +614,30 @@ package body Grt.Rtis_Utils is Prepend (Rstr, Sep); end if; end; - when Ghdl_Rtik_For_Generate => - declare - Iter : Ghdl_Rtin_Object_Acc; - Addr : Address; - begin - Prepend (Rstr, ')'); - Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); - Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); - Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); - Prepend (Rstr, '('); - Prepend (Rstr, Blk.Name); - Prepend (Rstr, Sep); - Ctxt := Get_Parent_Context (Ctxt); - end; + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Generate_Body => + if Blk.Parent.Kind = Ghdl_Rtik_For_Generate then + declare + Gen : constant Ghdl_Rtin_Generate_Acc := + To_Ghdl_Rtin_Generate_Acc (Blk.Parent); + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Gen.Name); + Prepend (Rstr, Sep); + end; + end if; + Ctxt := Get_Parent_Context (Ctxt); when others => Internal_Error ("grt.rtis_utils.get_path_name"); end case; diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb index ad8071937..c4147408d 100644 --- a/src/vhdl/canon.adb +++ b/src/vhdl/canon.adb @@ -1662,19 +1662,38 @@ package body Canon is when Iir_Kind_If_Generate_Statement => declare Clause : Iir; + Bod : Iir; Cond : Iir; + Alt_Num : Natural; begin Clause := El; + Alt_Num := 1; while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + if Canon_Flag_Add_Labels + and then Get_Alternative_Label (Bod) = Null_Identifier + then + declare + Str : String := Natural'Image (Alt_Num); + begin + -- Note: the label starts with a capitalized + -- letter, to avoid any clash with user's + -- identifiers. + Str (1) := 'B'; + Set_Alternative_Label + (Bod, Name_Table.Get_Identifier (Str)); + end; + end if; + if Canon_Flag_Expressions then Cond := Get_Condition (El); if Cond /= Null_Iir then Canon_Expression (Cond); end if; end if; - Canon_Generate_Statement_Body - (Top, Get_Generate_Statement_Body (Clause)); + Canon_Generate_Statement_Body (Top, Bod); Clause := Get_Generate_Else_Clause (Clause); + Alt_Num := Alt_Num + 1; end loop; end; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index 0ebe63226..a865da63d 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -6098,13 +6098,15 @@ package body Parse is -- { concurrent_statement } -- Note there is no END. This part is followed by: -- END GENERATE [ /generate/_label ] ; - function Parse_Generate_Statement_Body (Parent : Iir) return Iir + function Parse_Generate_Statement_Body (Parent : Iir; Label : Name_Id) + return Iir is Bod : Iir; begin Bod := Create_Iir (Iir_Kind_Generate_Statement_Body); Set_Location (Bod); Set_Parent (Bod, Parent); + Set_Alternative_Label (Bod, Label); -- Check for a block declarative item. case Current_Token is @@ -6161,6 +6163,18 @@ package body Parse is Parse_Concurrent_Statements (Bod); + case Current_Token is + when Tok_Elsif + | Tok_Else => + if Get_Kind (Parent) = Iir_Kind_If_Generate_Statement + or else Get_Kind (Parent) = Iir_Kind_If_Generate_Else_Clause + then + return Bod; + end if; + when others => + null; + end case; + Expect (Tok_End); -- Skip 'end' @@ -6168,7 +6182,7 @@ package body Parse is if Vhdl_Std >= Vhdl_08 and then Current_Token /= Tok_Generate then -- This is the 'end' of the generate_statement_body. - Check_End_Name (Null_Identifier, Bod); + Check_End_Name (Label, Bod); Scan_Semi_Colon ("generate statement body"); Expect (Tok_End); @@ -6226,7 +6240,7 @@ package body Parse is Scan; Set_Generate_Statement_Body - (Res, Parse_Generate_Statement_Body (Res)); + (Res, Parse_Generate_Statement_Body (Res, Null_Identifier)); Expect (Tok_Generate); Set_End_Has_Reserved_Id (Res, True); @@ -6247,22 +6261,35 @@ package body Parse is -- -- [ LRM93 9.7 ] -- generate_statement ::= - -- GENERATE_label : generation_scheme GENERATE + -- /generate/_label : generation_scheme GENERATE -- [ { block_declarative_item } -- BEGIN ] -- { concurrent_statement } - -- END GENERATE [ GENERATE_label ] ; + -- END GENERATE [ /generate/_label ] ; -- -- [ LRM93 9.7 ] -- generation_scheme ::= -- FOR GENERATE_parameter_specification -- | IF condition -- - -- FIXME: block_declarative item. + -- [ LRM08 11.8 ] + -- if_generate_statement ::= + -- /generate/_label : + -- IF [ /alternative/_label : ] condition GENERATE + -- generate_statement_body + -- { ELSIF [ /alternative/_label : ] condition GENERATE + -- generate_statement_body } + -- [ ELSE [ /alternative/_label : ] GENERATE + -- generate_statement_body ] + -- END GENERATE [ /generate/_label ] ; function Parse_If_Generate_Statement (Label : Name_Id; Loc : Location_Type) - return Iir_Generate_Statement + return Iir_Generate_Statement is Res : Iir_Generate_Statement; + Alt_Label : Name_Id; + Cond : Iir; + Clause : Iir; + Last : Iir; begin if Label = Null_Identifier then Error_Msg_Parse ("a generate statement must have a label"); @@ -6274,14 +6301,75 @@ package body Parse is -- Skip 'if'. Scan; - Set_Condition (Res, Parse_Expression); + Clause := Res; + Last := Null_Iir; + loop + Cond := Parse_Expression; + + Alt_Label := Null_Identifier; + if Current_Token = Tok_Colon then + if Get_Kind (Cond) = Iir_Kind_Simple_Name then + -- In fact the parsed condition was an alternate label. + Alt_Label := Get_Identifier (Cond); + Free_Iir (Cond); + else + Error_Msg_Parse ("alternative label must be an identifier"); + Free_Iir (Cond); + end if; - -- Skip 'generate' - Expect (Tok_Generate); - Scan; + -- Skip ':' + Scan; - Set_Generate_Statement_Body - (Res, Parse_Generate_Statement_Body (Res)); + Cond := Parse_Expression; + end if; + + Set_Condition (Clause, Cond); + + -- Skip 'generate' + Expect (Tok_Generate); + Scan; + + Set_Generate_Statement_Body + (Clause, Parse_Generate_Statement_Body (Clause, Alt_Label)); + + if Last /= Null_Iir then + Set_Generate_Else_Clause (Last, Clause); + end if; + Last := Clause; + + exit when Current_Token /= Tok_Elsif; + end loop; + + if Current_Token = Tok_Else then + Clause := Create_Iir (Iir_Kind_If_Generate_Else_Clause); + Set_Location (Clause); + + -- Skip 'else' + Scan; + + if Current_Token = Tok_Identifier then + Alt_Label := Current_Identifier; + + -- Skip identifier + Scan; + + Expect (Tok_Colon); + + -- Skip ':' + Scan; + else + Alt_Label := Null_Identifier; + end if; + + -- Skip 'generate' + Expect (Tok_Generate); + Scan; + + Set_Generate_Statement_Body + (Clause, Parse_Generate_Statement_Body (Clause, Alt_Label)); + + Set_Generate_Else_Clause (Last, Clause); + end if; Expect (Tok_Generate); Set_End_Has_Reserved_Id (Res, True); @@ -6476,17 +6564,23 @@ package body Parse is -- Try to find a label. if Current_Token = Tok_Identifier then Label := Current_Identifier; + + -- Skip identifier Scan; + if Current_Token = Tok_Colon then - -- The identifier is really a label. + -- The identifier is really a label. + + -- Skip ':' Scan; else - -- This is not a label. + -- This is not a label. Assume a concurrent assignment. Target := Create_Iir (Iir_Kind_Simple_Name); Set_Location (Target, Loc); Set_Identifier (Target, Label); Label := Null_Identifier; Target := Parse_Name_Suffix (Target); + Stmt := Parse_Concurrent_Assignment (Target); goto Has_Stmt; end if; @@ -6498,15 +6592,18 @@ package body Parse is else Postponed := True; end if; + + -- Skip 'postponed' Scan; end if; case Current_Token is - when Tok_End => + when Tok_End | Tok_Else | Tok_Elsif | Tok_When => + -- End of list. 'else', 'elseif' and 'when' can be used to + -- separate statements in a generate statement. Postponed_Not_Allowed; if Label /= Null_Identifier then - Error_Msg_Parse - ("no label is allowed before the 'end' keyword"); + Error_Msg_Parse ("label is not allowed here"); end if; return; when Tok_Identifier => @@ -6587,7 +6684,7 @@ package body Parse is << Has_Stmt >> null; - -- stmt can be null in case of error. + -- Stmt can be null in case of error. if Stmt /= Null_Iir then Set_Location (Stmt, Loc); if Label /= Null_Identifier then diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb index b64e9ac90..ac153f2e6 100644 --- a/src/vhdl/sem_stmts.adb +++ b/src/vhdl/sem_stmts.adb @@ -1549,28 +1549,41 @@ package body Sem_Stmts is procedure Sem_If_Generate_Statement (Stmt : Iir) is + Clause : Iir; Condition : Iir; begin -- LRM93 10.1 Declarative region. -- 12. A generate statement. Open_Declarative_Region; - Condition := Get_Condition (Stmt); - Condition := Sem_Condition (Condition); - -- LRM93 9.7 - -- the condition in a generation scheme of the second form must be - -- a static expression. - if Condition /= Null_Iir - and then Get_Expr_Staticness (Condition) < Globally - then - Error_Msg_Sem ("condition must be a static expression", Condition); - else - Set_Condition (Stmt, Condition); - end if; + Clause := Stmt; + while Clause /= Null_Iir loop + Condition := Get_Condition (Clause); + + if Condition /= Null_Iir then + Condition := Sem_Condition (Condition); + -- LRM93 9.7 + -- the condition in a generation scheme of the second form must be + -- a static expression. + if Condition /= Null_Iir + and then Get_Expr_Staticness (Condition) < Globally + then + Error_Msg_Sem + ("condition must be a static expression", Condition); + else + Set_Condition (Clause, Condition); + end if; + else + -- No condition for the last 'else' part. + pragma Assert (Get_Generate_Else_Clause (Clause) = Null_Iir); + null; + end if; - -- In the same declarative region. - Sem_Generate_Statement_Body (Stmt); + -- In the same declarative region. + Sem_Generate_Statement_Body (Clause); + Clause := Get_Generate_Else_Clause (Clause); + end loop; Close_Declarative_Region; end Sem_If_Generate_Statement; diff --git a/src/vhdl/translate/trans-chap1.adb b/src/vhdl/translate/trans-chap1.adb index ae2b10699..1f0e7d3e7 100644 --- a/src/vhdl/translate/trans-chap1.adb +++ b/src/vhdl/translate/trans-chap1.adb @@ -727,31 +727,39 @@ package body Trans.Chap1 is Parent_Info : Block_Info_Acc) is Spec : constant Iir := Get_Block_Specification (Block_Config); - Block : constant Iir := Get_Block_From_Block_Specification (Spec); - Info : constant Block_Info_Acc := Get_Info (Block); + Bod : constant Iir := Get_Block_From_Block_Specification (Spec); + Gen : constant Iir := Get_Parent (Bod); + Gen_Info : constant Generate_Info_Acc := Get_Info (Gen); + Bod_Info : constant Block_Info_Acc := Get_Info (Bod); Var : O_Dnode; If_Blk : O_If_Block; begin - -- Configure the block only if it was created. - Open_Temp; - Var := Create_Temp_Init - (Info.Block_Decls_Ptr_Type, - New_Value (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Scope), - Info.Block_Parent_Field))); + -- Configure the block only if block id matches. Start_If_Stmt (If_Blk, New_Compare_Op - (ON_Neq, - New_Obj_Value (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + (ON_Eq, + New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Gen_Info.Generate_Body_Id)), + New_Lit (New_Index_Lit (Unsigned_64 (Bod_Info.Block_Id))), Ghdl_Bool_Type)); - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - Translate_Block_Configuration_Calls (Block_Config, Block, Info); - Clear_Scope (Info.Block_Scope); - Finish_If_Stmt (If_Blk); + + Open_Temp; + Var := Create_Temp_Init + (Bod_Info.Block_Decls_Ptr_Type, + New_Convert_Ov + (New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Gen_Info.Generate_Parent_Field)), + Bod_Info.Block_Decls_Ptr_Type)); + Set_Scope_Via_Param_Ptr (Bod_Info.Block_Scope, Var); + Translate_Block_Configuration_Calls (Block_Config, Bod, Bod_Info); + Clear_Scope (Bod_Info.Block_Scope); Close_Temp; + + Finish_If_Stmt (If_Blk); end Translate_If_Generate_Block_Configuration_Calls; procedure Translate_Block_Configuration_Calls diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index 192c8ee0c..b62b12f93 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -633,6 +633,149 @@ package body Trans.Chap9 is end case; end Translate_Psl_Directive_Statement; + procedure Translate_If_Generate_Statement (Stmt : Iir; Origin : Iir) + is + Clause : Iir; + Bod : Iir; + Info : Block_Info_Acc; + Stmt_Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + Mark2 : Id_Mark_Type; + Num : Int32; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + Stmt_Info := Add_Info (Stmt, Kind_Generate); + Stmt_Info.Generate_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Stmt), Ghdl_Ptr_Type); + Stmt_Info.Generate_Body_Id := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Get_Identifier (Stmt), "_ID"), + Ghdl_Index_Type); + + -- Translate generate statement body. + Num := 0; + Clause := Stmt; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + Info := Add_Info (Bod, Kind_Block); + + Push_Identifier_Prefix (Mark2, Get_Alternative_Label (Bod)); + + Chap1.Start_Block_Decl (Bod); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + Info.Block_Id := Num; + + Chap9.Translate_Block_Declarations (Bod, Bod); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + Pop_Identifier_Prefix (Mark2); + Clause := Get_Generate_Else_Clause (Clause); + Num := Num + 1; + end loop; + + Pop_Identifier_Prefix (Mark); + end Translate_If_Generate_Statement; + + procedure Translate_For_Generate_Statement (Stmt : Iir; Origin : Iir) + is + Bod : constant Iir := Get_Generate_Statement_Body (Stmt); + Param : constant Iir := Get_Parameter_Specification (Stmt); + Iter_Type : constant Iir := Get_Type (Param); + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + It_Info : Ortho_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + Chap3.Translate_Object_Subtype (Param, True); + + Info := Add_Info (Bod, Kind_Block); + Chap1.Start_Block_Decl (Bod); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. This is + -- the first field (known by GRT). + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + -- Flag (if block was configured). + Info.Block_Configured_Field := Add_Instance_Factory_Field + (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); + + -- Iterator. + It_Info := Add_Info (Param, Kind_Iterator); + It_Info.Iterator_Var := Create_Var + (Create_Var_Identifier (Param), + Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type (Mode_Value)); + + Chap9.Translate_Block_Declarations (Bod, Bod); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + -- Create array type of block_decls_type + Info.Block_Decls_Array_Type := New_Array_Type + (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("INSTARRTYPE"), + Info.Block_Decls_Array_Type); + -- Create access to the array type. + Info.Block_Decls_Array_Ptr_Type := New_Access_Type + (Info.Block_Decls_Array_Type); + New_Type_Decl (Create_Identifier ("INSTARRPTR"), + Info.Block_Decls_Array_Ptr_Type); + + -- Add a field in the parent instance (Pop_Instance_Factory + -- has already been called). This is a pointer INSTARRPTR + -- to an array INSTARRTYPE of instace. The size of each + -- element is stored in the RTI. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Stmt), + Info.Block_Decls_Array_Ptr_Type); + + Pop_Identifier_Prefix (Mark); + end Translate_For_Generate_Statement; + + procedure Translate_Block_Statement (Stmt : Iir; Origin : Iir) + is + Hdr : constant Iir_Block_Header := Get_Block_Header (Stmt); + Guard : constant Iir := Get_Guard_Decl (Stmt); + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + Info := Add_Info (Stmt, Kind_Block); + Chap1.Start_Block_Decl (Stmt); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Implicit guard signal. + if Guard /= Null_Iir then + Chap4.Translate_Declaration (Guard); + end if; + + -- generics, ports. + if Hdr /= Null_Iir then + Chap4.Translate_Generic_Chain (Hdr); + Chap4.Translate_Port_Chain (Hdr); + end if; + + Chap9.Translate_Block_Declarations (Stmt, Origin); + + Pop_Instance_Factory (Info.Block_Scope'Access); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field (Create_Identifier_Without_Prefix (Stmt), + Info.Block_Scope); + end Translate_Block_Statement; + -- Create the instance for block BLOCK. -- ORIGIN can be either an entity, an architecture or a block statement. procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) @@ -657,128 +800,11 @@ package body Trans.Chap9 is when Iir_Kind_Component_Instantiation_Statement => Translate_Component_Instantiation_Statement (El); when Iir_Kind_Block_Statement => - declare - Info : Block_Info_Acc; - Hdr : Iir_Block_Header; - Guard : Iir; - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - Info := Add_Info (El, Kind_Block); - Chap1.Start_Block_Decl (El); - Push_Instance_Factory (Info.Block_Scope'Access); - - Guard := Get_Guard_Decl (El); - if Guard /= Null_Iir then - Chap4.Translate_Declaration (Guard); - end if; - - -- generics, ports. - Hdr := Get_Block_Header (El); - if Hdr /= Null_Iir then - Chap4.Translate_Generic_Chain (Hdr); - Chap4.Translate_Port_Chain (Hdr); - end if; - - Chap9.Translate_Block_Declarations (El, Origin); - - Pop_Instance_Factory (Info.Block_Scope'Access); - Pop_Identifier_Prefix (Mark); - - -- Create a field in the parent record. - Add_Scope_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Scope); - end; + Translate_Block_Statement (El, Origin); when Iir_Kind_For_Generate_Statement => - declare - Bod : constant Iir := Get_Generate_Statement_Body (El); - Param : constant Iir := Get_Parameter_Specification (El); - Info : Block_Info_Acc; - Mark : Id_Mark_Type; - Iter_Type : constant Iir := Get_Type (Param); - It_Info : Ortho_Info_Acc; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - Chap3.Translate_Object_Subtype (Param, True); - - Info := Add_Info (Bod, Kind_Block); - Chap1.Start_Block_Decl (Bod); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- Add a parent field in the current instance. This is - -- the first field (known by GRT). - Info.Block_Origin_Field := Add_Instance_Factory_Field - (Get_Identifier ("ORIGIN"), - Get_Info (Origin).Block_Decls_Ptr_Type); - - -- Flag (if block was configured). - Info.Block_Configured_Field := - Add_Instance_Factory_Field - (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); - - -- Iterator. - It_Info := Add_Info (Param, Kind_Iterator); - It_Info.Iterator_Var := Create_Var - (Create_Var_Identifier (Param), - Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type - (Mode_Value)); - - Chap9.Translate_Block_Declarations (Bod, Bod); - - Pop_Instance_Factory (Info.Block_Scope'Access); - - -- Create array type of block_decls_type - Info.Block_Decls_Array_Type := New_Array_Type - (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); - New_Type_Decl (Create_Identifier ("INSTARRTYPE"), - Info.Block_Decls_Array_Type); - -- Create access to the array type. - Info.Block_Decls_Array_Ptr_Type := New_Access_Type - (Info.Block_Decls_Array_Type); - New_Type_Decl (Create_Identifier ("INSTARRPTR"), - Info.Block_Decls_Array_Ptr_Type); - - -- Add a field in the parent instance (Pop_Instance_Factory - -- has already been called). This is a pointer INSTARRPTR - -- to an array INSTARRTYPE of instace. The size of each - -- element is stored in the RTI. - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Decls_Array_Ptr_Type); - - Pop_Identifier_Prefix (Mark); - end; + Translate_For_Generate_Statement (El, Origin); when Iir_Kind_If_Generate_Statement => - declare - Bod : constant Iir := Get_Generate_Statement_Body (El); - Info : Block_Info_Acc; - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - Info := Add_Info (Bod, Kind_Block); - Chap1.Start_Block_Decl (Bod); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- Add a parent field in the current instance. - Info.Block_Origin_Field := Add_Instance_Factory_Field - (Get_Identifier ("ORIGIN"), - Get_Info (Origin).Block_Decls_Ptr_Type); - - Chap9.Translate_Block_Declarations (Bod, Bod); - - Pop_Instance_Factory (Info.Block_Scope'Access); - - -- Create an access field in the parent record. - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Decls_Ptr_Type); - - Pop_Identifier_Prefix (Mark); - end; + Translate_If_Generate_Statement (El, Origin); when others => Error_Kind ("translate_block_declarations", El); end case; @@ -863,6 +889,24 @@ package body Trans.Chap9 is Finish_Subprogram_Body; end Translate_Component_Instantiation_Subprogram; + procedure Translate_Generate_Statement_Body_Subprograms + (Bod : Iir; Base_Info : Block_Info_Acc) + is + Info : constant Block_Info_Acc := Get_Info (Bod); + Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; + begin + Subprgs.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + Info.Block_Origin_Field, + Info.Block_Scope'Access); + Translate_Block_Subprograms (Bod, Bod); + Clear_Scope (Base_Info.Block_Scope); + Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end Translate_Generate_Statement_Body_Subprograms; + -- Translate concurrent statements into subprograms. procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) is @@ -916,24 +960,25 @@ package body Trans.Chap9 is end if; Translate_Block_Subprograms (Stmt, Base_Block); end; - when Iir_Kind_For_Generate_Statement - | Iir_Kind_If_Generate_Statement => + when Iir_Kind_For_Generate_Statement => + Translate_Generate_Statement_Body_Subprograms + (Get_Generate_Statement_Body (Stmt), Base_Info); + when Iir_Kind_If_Generate_Statement => declare - Bod : constant Iir := Get_Generate_Statement_Body (Stmt); - Info : constant Block_Info_Acc := Get_Info (Bod); - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; + Clause : Iir; + Bod : Iir; + Mark2 : Id_Mark_Type; begin - Subprgs.Push_Subprg_Instance (Info.Block_Scope'Access, - Info.Block_Decls_Ptr_Type, - Wki_Instance, - Prev_Subprg_Instance); - Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, - Info.Block_Origin_Field, - Info.Block_Scope'Access); - Translate_Block_Subprograms (Bod, Bod); - Clear_Scope (Base_Info.Block_Scope); - Subprgs.Pop_Subprg_Instance - (Wki_Instance, Prev_Subprg_Instance); + Clause := Stmt; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + Push_Identifier_Prefix + (Mark2, Get_Alternative_Label (Bod)); + Translate_Generate_Statement_Body_Subprograms + (Bod, Base_Info); + Pop_Identifier_Prefix (Mark2); + Clause := Get_Generate_Else_Clause (Clause); + end loop; end; when others => Error_Kind ("translate_block_subprograms", Stmt); @@ -1522,51 +1567,78 @@ package body Trans.Chap9 is procedure Elab_If_Generate_Statement (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) is - Condition : constant Iir := Get_Condition (Stmt); - Bod : constant Iir := Get_Generate_Statement_Body (Stmt); - Info : constant Block_Info_Acc := Get_Info (Bod); Parent_Info : constant Block_Info_Acc := Get_Info (Parent); - Var : O_Dnode; - Blk : O_If_Block; - V : O_Lnode; - begin - Open_Temp; - Var := Create_Temp (Info.Block_Decls_Ptr_Type); - Start_If_Stmt (Blk, Chap7.Translate_Expression (Condition)); - New_Assign_Stmt - (New_Obj (Var), - Gen_Alloc (Alloc_System, - New_Lit (Get_Scope_Size (Info.Block_Scope)), - Info.Block_Decls_Ptr_Type)); - New_Else_Stmt (Blk); - New_Assign_Stmt - (New_Obj (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type))); - Finish_If_Stmt (Blk); + -- Used to get Block_Parent_Field, set in the first generate statement + -- body. + Stmt_Info : constant Generate_Info_Acc := Get_Info (Stmt); - -- Add a link to child in parent. - V := Get_Instance_Ref (Parent_Info.Block_Scope); - V := New_Selected_Element (V, Info.Block_Parent_Field); - New_Assign_Stmt (V, New_Obj_Value (Var)); + -- Set the instance field in the parent. + procedure Set_Parent_Field (Val : O_Enode; Num : Nat32) + is + V : O_Lnode; + begin + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Stmt_Info.Generate_Parent_Field); + New_Assign_Stmt (V, Val); - Start_If_Stmt - (Blk, - New_Compare_Op - (ON_Neq, - New_Obj_Value (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), - Ghdl_Bool_Type)); - -- Add a link to parent in child. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), - Get_Instance_Access (Base_Block)); - -- Elaborate block - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - Elab_Block_Declarations (Bod, Bod); - Clear_Scope (Info.Block_Scope); - Finish_If_Stmt (Blk); - Close_Temp; + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Stmt_Info.Generate_Body_Id); + New_Assign_Stmt (V, New_Lit (New_Index_Lit (Unsigned_64 (Num)))); + end Set_Parent_Field; + + procedure Elab_If_Clause (Clause : Iir) + is + Condition : constant Iir := Get_Condition (Clause); + Bod : constant Iir := Get_Generate_Statement_Body (Clause); + Info : constant Block_Info_Acc := Get_Info (Bod); + Var : O_Dnode; + Blk : O_If_Block; + N_Clause : Iir; + begin + Open_Temp; + + Var := Create_Temp (Info.Block_Decls_Ptr_Type); + if Condition /= Null_Iir then + Start_If_Stmt (Blk, Chap7.Translate_Expression (Condition)); + end if; + New_Assign_Stmt + (New_Obj (Var), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Info.Block_Scope)), + Info.Block_Decls_Ptr_Type)); + + -- Add a link to child in parent. This must be done before + -- elaboration, in case of use. + Set_Parent_Field + (New_Convert_Ov (New_Obj_Value (Var), Ghdl_Ptr_Type), + Info.Block_Id); + + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Elab_Block_Declarations (Bod, Bod); + Clear_Scope (Info.Block_Scope); + + if Condition /= Null_Iir then + New_Else_Stmt (Blk); + N_Clause := Get_Generate_Else_Clause (Clause); + if N_Clause /= Null_Iir then + Elab_If_Clause (N_Clause); + else + Set_Parent_Field + (New_Lit (New_Null_Access (Ghdl_Ptr_Type)), + Info.Block_Id + 1); + end if; + Finish_If_Stmt (Blk); + end if; + Close_Temp; + end Elab_If_Clause; + begin + Elab_If_Clause (Stmt); end Elab_If_Generate_Statement; procedure Elab_For_Generate_Statement diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index ed483fe17..a55447a47 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -154,8 +154,8 @@ package body Trans.Rtis is Ghdl_Rtin_Component_Nbr_Child : O_Fnode; Ghdl_Rtin_Component_Children : O_Fnode; - procedure Rti_Initialize - is + -- Create all the declarations for RTIs. + procedure Rti_Initialize is begin -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...) declare @@ -708,149 +708,221 @@ package body Trans.Rtis is end Rti_Initialize; - type Rti_Array is array (1 .. 8) of O_Dnode; - type Rti_Array_List; - type Rti_Array_List_Acc is access Rti_Array_List; - type Rti_Array_List is record - Rtis : Rti_Array; - Next : Rti_Array_List_Acc; - end record; + package Rti_Builders is + type Rti_Block is limited private; - type Rti_Block is record - Depth : Rti_Depth_Type; - Nbr : Integer; - List : Rti_Array_List; - Last_List : Rti_Array_List_Acc; - Last_Nbr : Integer; - end record; - - Cur_Block : Rti_Block := (Depth => 0, - Nbr => 0, - List => (Rtis => (others => O_Dnode_Null), - Next => null), - Last_List => null, - Last_Nbr => 0); - - Free_List : Rti_Array_List_Acc := null; - - procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) - is - Ndepth : Rti_Depth_Type; - begin - if Deeper then - Ndepth := Cur_Block.Depth + 1; - else - Ndepth := Cur_Block.Depth; - end if; - Prev := Cur_Block; - Cur_Block := (Depth => Ndepth, - Nbr => 0, - List => (Rtis => (others => O_Dnode_Null), - Next => null), - Last_List => null, - Last_Nbr => 0); - end Push_Rti_Node; - - procedure Add_Rti_Node (Node : O_Dnode) - is - begin - if Node = O_Dnode_Null then - -- FIXME: temporary for not yet handled types. - return; - end if; - if Cur_Block.Last_Nbr = Rti_Array'Last then - -- Append a new block. - declare - N : Rti_Array_List_Acc; - begin - if Free_List = null then - N := new Rti_Array_List; - else - N := Free_List; - Free_List := N.Next; - end if; - N.Next := null; - if Cur_Block.Last_List = null then - Cur_Block.List.Next := N; - else - Cur_Block.Last_List.Next := N; - end if; - Cur_Block.Last_List := N; - end; - Cur_Block.Last_Nbr := 1; - else - Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; - end if; - if Cur_Block.Last_List = null then - Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; - else - Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; - end if; - Cur_Block.Nbr := Cur_Block.Nbr + 1; - end Add_Rti_Node; + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type; - function Generate_Rti_Array (Id : O_Ident) return O_Dnode - is - Arr_Type : O_Tnode; - List : O_Array_Aggr_List; - L : Rti_Array_List_Acc; - Nbr : Integer; - Val : O_Cnode; - Res : O_Dnode; - begin - Arr_Type := New_Constrained_Array_Type - (Ghdl_Rti_Array, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr + 1))); - New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); - Start_Const_Value (Res); - Start_Array_Aggr (List, Arr_Type); - Nbr := Cur_Block.Nbr; - for I in Cur_Block.List.Rtis'Range loop - exit when I > Nbr; - New_Array_Aggr_El - (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), - Ghdl_Rti_Access)); - end loop; - L := Cur_Block.List.Next; - while L /= null loop - Nbr := Nbr - Cur_Block.List.Rtis'Length; - for I in L.Rtis'Range loop + procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True); + + -- Save NODE in a list. + procedure Add_Rti_Node (Node : O_Dnode); + + -- Convert the list of nodes into a null-terminated array, declared + -- using ID. + function Generate_Rti_Array (Id : O_Ident) return O_Dnode; + + -- Get the number of nodes in the array (without the last null entry). + function Get_Rti_Array_Length return Unsigned_64; + + procedure Pop_Rti_Node (Prev : Rti_Block); + + private + type Rti_Array is array (1 .. 8) of O_Dnode; + type Rti_Array_List; + type Rti_Array_List_Acc is access Rti_Array_List; + type Rti_Array_List is record + Rtis : Rti_Array; + Next : Rti_Array_List_Acc; + end record; + + type Rti_Block is record + -- Depth of the block. + Depth : Rti_Depth_Type; + + -- Number of children. + Nbr : Integer; + + -- Array for the fist children. + List : Rti_Array_List; + + -- Linked list for the following children. + Last_List : Rti_Array_List_Acc; + + -- Number of entries used in the last array. Used to detect if a + -- new array has to be allocated. + Last_Nbr : Integer; + end record; + end Rti_Builders; + + package body Rti_Builders is + Cur_Block : Rti_Block := (Depth => 0, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + + Free_List : Rti_Array_List_Acc := null; + + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type is + begin + if Var = Null_Var or else Is_Var_Field (Var) then + return Cur_Block.Depth; + else + -- Global variable. No depth. + return 0; + end if; + end Get_Depth_From_Var; + + procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) + is + Ndepth : Rti_Depth_Type; + begin + -- Save current state. + Prev := Cur_Block; + + if Deeper then + -- Increase depth for nested declarations (usual case). + Ndepth := Cur_Block.Depth + 1; + else + -- Same depth for non-semantically nested declarations (but + -- lexically nested), eg: physical literals, record elements. + Ndepth := Cur_Block.Depth; + end if; + + -- Create new empty state. + Cur_Block := (Depth => Ndepth, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + end Push_Rti_Node; + + procedure Add_Rti_Node (Node : O_Dnode) is + begin + if Node = O_Dnode_Null then + -- FIXME: temporary for not yet handled types. + return; + end if; + + if Cur_Block.Last_Nbr = Rti_Array'Last then + -- Append a new block. + declare + N : Rti_Array_List_Acc; + begin + if Free_List = null then + -- Create a new one. + N := new Rti_Array_List; + else + -- Recycle from the free list. + N := Free_List; + Free_List := N.Next; + end if; + + -- Initialize. + N.Next := null; + + -- Link. + if Cur_Block.Last_List = null then + Cur_Block.List.Next := N; + else + Cur_Block.Last_List.Next := N; + end if; + Cur_Block.Last_List := N; + end; + + -- Use first entry. + Cur_Block.Last_Nbr := 1; + else + + -- Allocate new entry in the block. + Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; + end if; + + if Cur_Block.Last_List = null then + -- Entry in the first block. + Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; + else + -- More than one block. + Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; + end if; + + -- An entry was added. + Cur_Block.Nbr := Cur_Block.Nbr + 1; + end Add_Rti_Node; + + function Generate_Rti_Array (Id : O_Ident) return O_Dnode + is + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + L : Rti_Array_List_Acc; + Nbr : Integer; + Val : O_Cnode; + Res : O_Dnode; + begin + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr + 1))); + New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); + Start_Const_Value (Res); + Start_Array_Aggr (List, Arr_Type); + Nbr := Cur_Block.Nbr; + + -- First chunk. + for I in Cur_Block.List.Rtis'Range loop exit when I > Nbr; New_Array_Aggr_El - (List, New_Global_Unchecked_Address (L.Rtis (I), - Ghdl_Rti_Access)); + (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), + Ghdl_Rti_Access)); end loop; - L := L.Next; - end loop; - New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); - Finish_Array_Aggr (List, Val); - Finish_Const_Value (Res, Val); - return Res; - end Generate_Rti_Array; - procedure Pop_Rti_Node (Prev : Rti_Block) - is - L : Rti_Array_List_Acc; - begin - L := Cur_Block.List.Next; - if L /= null then - Cur_Block.Last_List.Next := Free_List; - Free_List := Cur_Block.List.Next; - Cur_Block.List.Next := null; - end if; - Cur_Block := Prev; - end Pop_Rti_Node; + -- Next chunks. + L := Cur_Block.List.Next; + while L /= null loop + Nbr := Nbr - Cur_Block.List.Rtis'Length; + for I in L.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (L.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := L.Next; + end loop; - function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type - is - begin - if Var = Null_Var or else Is_Var_Field (Var) then - return Cur_Block.Depth; - else - return 0; - end if; - end Get_Depth_From_Var; + -- Append a null entry. + New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); + + Finish_Array_Aggr (List, Val); + Finish_Const_Value (Res, Val); + return Res; + end Generate_Rti_Array; + + function Get_Rti_Array_Length return Unsigned_64 is + begin + return Unsigned_64 (Cur_Block.Nbr); + end Get_Rti_Array_Length; + + procedure Pop_Rti_Node (Prev : Rti_Block) + is + L : Rti_Array_List_Acc; + begin + -- Put chunks to Free_List. + L := Cur_Block.List.Next; + if L /= null then + Cur_Block.Last_List.Next := Free_List; + Free_List := Cur_Block.List.Next; + Cur_Block.List.Next := null; + end if; + + -- Restore context. + Cur_Block := Prev; + end Pop_Rti_Node; + end Rti_Builders; + + use Rti_Builders; function Generate_Common (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) @@ -1910,7 +1982,8 @@ package body Trans.Rtis is end Generate_Object; procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); - procedure Generate_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_If_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_For_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode); procedure Generate_Declaration_Chain (Chain : Iir); procedure Generate_Component_Declaration (Comp : Iir) @@ -1946,7 +2019,7 @@ package body Trans.Rtis is New_Global_Address (Name, Char_Ptr_Type)); New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr))); + Get_Rti_Array_Length)); New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Res); @@ -2205,7 +2278,7 @@ package body Trans.Rtis is Pop_Identifier_Prefix (Mark); when Iir_Kind_If_Generate_Statement => Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Generate_Generate_Statement (Stmt, Parent_Rti); + Generate_If_Generate_Statement (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); when Iir_Kind_For_Generate_Statement => Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); @@ -2227,7 +2300,7 @@ package body Trans.Rtis is Pop_Identifier_Prefix (Mark); end if; end; - Generate_Generate_Statement (Stmt, Parent_Rti); + Generate_For_Generate_Statement (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); when Iir_Kind_Component_Instantiation_Statement => Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); @@ -2248,22 +2321,90 @@ package body Trans.Rtis is end loop; end Generate_Concurrent_Statement_Chain; - procedure Generate_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode) + procedure Generate_If_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode) + is + Info : constant Generate_Info_Acc := Get_Info (Blk); + Clause : Iir; + Bod : Iir; + + Name : O_Dnode; + List : O_Record_Aggr_List; + Num : Natural; + + Rti : O_Dnode; + Arr : O_Dnode; + + Prev : Rti_Block; + + Field_Off : O_Cnode; + Res : O_Cnode; + + Mark : Id_Mark_Type; + begin + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Block); + Push_Rti_Node (Prev); + + Clause := Blk; + Num := 0; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + Generate_Block (Bod, Rti); + Pop_Identifier_Prefix (Mark); + Clause := Get_Generate_Else_Clause (Clause); + Num := Num + 1; + end loop; + + Name := Generate_Name (Blk); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Rti); + + Start_Record_Aggr (List, Ghdl_Rtin_Block); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_If_Generate)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + + -- Field Loc: offset in the instance of the entity. + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Get_Info (Blk).Generate_Parent_Field, Ghdl_Ptr_Type); + New_Record_Aggr_El (List, Field_Off); + + New_Record_Aggr_El (List, Generate_Linecol (Blk)); + + -- Field Parent: RTI of the parent. + New_Record_Aggr_El (List, New_Rti_Address (Parent_Rti)); + + -- Fields Nbr_Child and Children. + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, Get_Rti_Array_Length)); + New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + + Finish_Const_Value (Rti, Res); + + Pop_Rti_Node (Prev); + + -- Put the result in the parent list. + Add_Rti_Node (Rti); + + -- Store the RTI. + Info.Generate_Rti_Const := Rti; + end Generate_If_Generate_Statement; + + procedure Generate_For_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode) is Info : constant Ortho_Info_Acc := Get_Info (Blk); Bod : constant Iir := Get_Generate_Statement_Body (Blk); Bod_Info : constant Block_Info_Acc := Get_Info (Bod); - Child : Iir; - Child_Rti : O_Cnode; Name : O_Dnode; List : O_Record_Aggr_List; Rti : O_Dnode; - Kind : O_Cnode; - Size : O_Cnode; - Prev : Rti_Block; Field_Off : O_Cnode; @@ -2275,43 +2416,22 @@ package body Trans.Rtis is O_Storage_Public, Ghdl_Rtin_Generate); Push_Rti_Node (Prev); - Field_Off := New_Offsetof - (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), - Bod_Info.Block_Parent_Field, Ghdl_Ptr_Type); - - case Get_Kind (Blk) is - when Iir_Kind_If_Generate_Statement => - Push_Identifier_Prefix (Mark, "BOD"); - Generate_Block (Bod, Rti); - Pop_Identifier_Prefix (Mark); - Kind := Ghdl_Rtik_If_Generate; - Size := Ghdl_Index_0; - if Get_Generate_Else_Clause (Blk) = Null_Iir then - Child := Bod; - else - Child := Null_Iir; - end if; - when Iir_Kind_For_Generate_Statement => - Push_Identifier_Prefix (Mark, "BOD"); - Generate_Block (Bod, Rti); - Pop_Identifier_Prefix (Mark); - Kind := Ghdl_Rtik_For_Generate; - Size := New_Sizeof (Get_Scope_Type (Bod_Info.Block_Scope), - Ghdl_Index_Type); - Child := Bod; - when others => - Error_Kind ("rti.generate_generate", Blk); - end case; + Push_Identifier_Prefix (Mark, "BOD"); + Generate_Block (Bod, Rti); + Pop_Identifier_Prefix (Mark); Name := Generate_Name (Blk); Start_Const_Value (Rti); Start_Record_Aggr (List, Ghdl_Rtin_Generate); - New_Record_Aggr_El (List, Generate_Common (Kind)); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_For_Generate)); New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); -- Field Loc: offset in the instance of the entity. + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Bod_Info.Block_Parent_Field, Ghdl_Ptr_Type); New_Record_Aggr_El (List, Field_Off); New_Record_Aggr_El (List, Generate_Linecol (Blk)); @@ -2322,15 +2442,12 @@ package body Trans.Rtis is -- Field Size: size of the instance. -- For for-generate: size of instance, which gives the stride in the -- sub-blocks array. - New_Record_Aggr_El (List, Size); + New_Record_Aggr_El + (List, New_Sizeof (Get_Scope_Type (Bod_Info.Block_Scope), + Ghdl_Index_Type)); -- Child. - if Child = Null_Iir then - Child_Rti := New_Null_Access (Ghdl_Rti_Access); - else - Child_Rti := Get_Context_Rti (Child); - end if; - New_Record_Aggr_El (List, Child_Rti); + New_Record_Aggr_El (List, Get_Context_Rti (Bod)); Finish_Record_Aggr (List, Res); @@ -2347,7 +2464,7 @@ package body Trans.Rtis is -- Not sure we need to store it (except maybe for 'path_name ?) Info.Block_Rti_Const := Rti; end if; - end Generate_Generate_Statement; + end Generate_For_Generate_Statement; procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode) is @@ -2483,8 +2600,7 @@ package body Trans.Rtis is -- Fields Nbr_Child and Children. New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr))); + (List, New_Unsigned_Literal (Ghdl_Index_Type, Get_Rti_Array_Length)); New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Res); diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index 79f02c141..9a10b6560 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -315,8 +315,7 @@ package Trans is procedure Restore_Local_Identifier (Id : Local_Identifier_Type); -- Create an identifier from IIR node ID without the prefix. - function Create_Identifier_Without_Prefix (Id : Iir) - return O_Ident; + function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident; function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) return O_Ident; @@ -638,6 +637,7 @@ package Trans is Kind_Psl_Directive, Kind_Loop, Kind_Block, + Kind_Generate, Kind_Component, Kind_Field, Kind_Package, @@ -1249,6 +1249,11 @@ package Trans is Block_Decls_Array_Type : O_Tnode; Block_Decls_Array_Ptr_Type : O_Tnode; + -- For if-generate generate statement body: the identifier of the + -- body. Used to know which block_configuration applies to the + -- block. + Block_Id : Nat32; + -- Subprogram which elaborates the block (for entity or arch). Block_Elab_Subprg : O_Dnode; -- Size of the block instance. @@ -1262,6 +1267,19 @@ package Trans is -- RTI constant for the block. Block_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Generate => + -- Like Block_Parent_Field: field in the instance for the + -- sub-block. Always a Ghdl_Ptr_Type, as there are many possible + -- types for the sub-block instance (if/case generate). + Generate_Parent_Field : O_Fnode; + + -- Identifier number of the generate statement body. Used for + -- configuring sub-block, and for grt to index the rti. + Generate_Body_Id : O_Fnode; + + -- RTI for the generate statement. + Generate_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Component => -- How to access to component interfaces. Comp_Scope : aliased Var_Scope_Type; @@ -1366,6 +1384,7 @@ package Trans is subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive); subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); + subtype Generate_Info_Acc is Ortho_Info_Acc (Kind_Generate); subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field); subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config); |