diff options
Diffstat (limited to 'src/vhdl')
| -rw-r--r-- | src/vhdl/iirs_utils.adb | 37 | ||||
| -rw-r--r-- | src/vhdl/sem_stmts.adb | 7 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap2.adb | 328 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap3.adb | 19 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap3.ads | 3 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap4.adb | 156 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap4.ads | 4 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap6.adb | 4 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap6.ads | 1 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap7.adb | 83 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap8.adb | 2202 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap8.ads | 52 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap9.adb | 29 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-helpers2.adb | 3 | ||||
| -rw-r--r-- | src/vhdl/translate/trans.adb | 70 | ||||
| -rw-r--r-- | src/vhdl/translate/trans.ads | 95 | ||||
| -rw-r--r-- | src/vhdl/translate/trans_decls.ads | 1 | ||||
| -rw-r--r-- | src/vhdl/translate/translation.adb | 13 |
18 files changed, 2301 insertions, 806 deletions
diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb index 544b0d5..189f0f3 100644 --- a/src/vhdl/iirs_utils.adb +++ b/src/vhdl/iirs_utils.adb @@ -350,6 +350,25 @@ package body Iirs_Utils is end if; end Is_Signal_Name; + function Is_Signal_Object (Name : Iir) return Boolean + is + Adecl: Iir; + begin + Adecl := Get_Object_Prefix (Name, True); + case Get_Kind (Adecl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + return True; + when Iir_Kind_Object_Alias_Declaration => + -- Must have been handled by Get_Object_Prefix. + raise Internal_Error; + when others => + return False; + end case; + end Is_Signal_Object; + function Get_Association_Interface (Assoc : Iir) return Iir is Formal : Iir; @@ -1201,24 +1220,6 @@ package body Iirs_Utils is end case; end Get_Entity_From_Entity_Aspect; - function Is_Signal_Object (Name : Iir) return Boolean - is - Adecl: Iir; - begin - Adecl := Get_Object_Prefix (Name, True); - case Get_Kind (Adecl) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kinds_Signal_Attribute => - return True; - when Iir_Kind_Object_Alias_Declaration => - raise Internal_Error; - when others => - return False; - end case; - end Is_Signal_Object; - -- LRM08 4.7 Package declarations -- If the package header is empty, the package declared by a package -- declaration is called a simple package. diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb index a1d3275..4541be4 100644 --- a/src/vhdl/sem_stmts.adb +++ b/src/vhdl/sem_stmts.adb @@ -1246,11 +1246,16 @@ package body Sem_Stmts is begin Sem_Procedure_Call (Call, Stmt); - -- Set suspend flag. + -- Set suspend flag, if calling a suspendable procedure + -- from a procedure or from a process. Imp := Get_Implementation (Call); if Imp /= Null_Iir and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration and then Get_Suspend_Flag (Imp) + and then (Get_Kind (Get_Current_Subprogram) + /= Iir_Kind_Function_Declaration) + and then (Get_Kind (Get_Current_Subprogram) + /= Iir_Kind_Sensitized_Process_Statement) then Set_Suspend_Flag (Stmt, True); Mark_Suspendable (Stmt); diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 5fa301b..8a9f7a0 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -29,6 +29,7 @@ with Trans.Chap5; with Trans.Chap6; with Trans.Chap8; with Trans.Rtis; +with Trans.Helpers2; with Trans_Decls; use Trans_Decls; with Translation; use Translation; @@ -78,36 +79,6 @@ package body Trans.Chap2 is end if; end Push_Subprg_Identifier; - procedure Translate_Subprogram_Interfaces (Spec : Iir) - is - Inter : Iir; - Mark : Id_Mark_Type; - begin - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - Push_Subprg_Identifier (Spec, Mark); - - -- Translate interface types. - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Chap3.Translate_Object_Subtype (Inter); - Inter := Get_Chain (Inter); - end loop; - Pop_Identifier_Prefix (Mark); - end Translate_Subprogram_Interfaces; - - procedure Elab_Subprogram_Interfaces (Spec : Iir) - is - Inter : Iir; - begin - -- Translate interface types. - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Chap3.Elab_Object_Subtype (Get_Type (Inter)); - Inter := Get_Chain (Inter); - end loop; - end Elab_Subprogram_Interfaces; - -- Return the type of a subprogram interface. -- Return O_Tnode_Null if the parameter is passed through the -- interface record. @@ -145,6 +116,76 @@ package body Trans.Chap2 is end if; end Translate_Interface_Type; + procedure Translate_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + Mark : Id_Mark_Type; + Info : Subprg_Info_Acc; + El_List : O_Element_List; + Arg_Info : Ortho_Info_Acc; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Translate_Object_Subtype (Inter); + Inter := Get_Chain (Inter); + end loop; + + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + -- Create the param record (except for foreign subprogram). + Info := Get_Info (Spec); + Inter := Get_Interface_Declaration_Chain (Spec); + if (Inter /= Null_Iir or else Get_Suspend_Flag (Spec)) + and then not Get_Foreign_Flag (Spec) + then + Start_Record_Type (El_List); + while Inter /= Null_Iir loop + Arg_Info := Add_Info (Inter, Kind_Interface); + New_Record_Field (El_List, Arg_Info.Interface_Field, + Create_Identifier_Without_Prefix (Inter), + Translate_Interface_Type (Inter, False)); + Inter := Get_Chain (Inter); + end loop; + + if Get_Suspend_Flag (Spec) then + New_Record_Field (El_List, Info.Subprg_State_Field, + Get_Identifier ("STATE"), Ghdl_Index_Type); + New_Record_Field (El_List, Info.Subprg_Locvars_Field, + Get_Identifier ("FRAME"), Ghdl_Ptr_Type); + end if; + + -- Declare the record type and an access to the record. + Finish_Record_Type (El_List, Info.Subprg_Params_Type); + New_Type_Decl (Create_Identifier ("PARAMSTYPE"), + Info.Subprg_Params_Type); + Info.Subprg_Params_Ptr := + New_Access_Type (Info.Subprg_Params_Type); + New_Type_Decl (Create_Identifier ("PARAMSPTR"), + Info.Subprg_Params_Ptr); + else + Info.Subprg_Params_Type := O_Tnode_Null; + Info.Subprg_Params_Ptr := O_Tnode_Null; + end if; + end if; + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Interfaces; + + procedure Elab_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + begin + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Elab_Object_Subtype (Get_Type (Inter)); + Inter := Get_Chain (Inter); + end loop; + end Elab_Subprogram_Interfaces; + procedure Translate_Subprogram_Declaration (Spec : Iir) is Info : constant Subprg_Info_Acc := Get_Info (Spec); @@ -155,7 +196,6 @@ package body Trans.Chap2 is Arg_Info : Ortho_Info_Acc; Tinfo : Type_Info_Acc; Interface_List : O_Inter_List; - El_List : O_Element_List; Mark : Id_Mark_Type; Rtype : Iir; Id : O_Ident; @@ -213,33 +253,6 @@ package body Trans.Chap2 is Info.Res_Interface := O_Dnode_Null; end if; else - -- Create info for each interface of the procedure. - -- For parameters passed via copy and that needs a copy-out, - -- gather them in a record. An access to the record is then - -- passed to the procedure. - Inter := Get_Interface_Declaration_Chain (Spec); - if Inter /= Null_Iir and then not Is_Foreign then - Start_Record_Type (El_List); - while Inter /= Null_Iir loop - Arg_Info := Add_Info (Inter, Kind_Interface); - New_Record_Field (El_List, Arg_Info.Interface_Field, - Create_Identifier_Without_Prefix (Inter), - Translate_Interface_Type (Inter, False)); - Inter := Get_Chain (Inter); - end loop; - -- Declare the record type and an access to the record. - Finish_Record_Type (El_List, Info.Subprg_Params_Type); - New_Type_Decl (Create_Identifier ("PARAMSTYPE"), - Info.Subprg_Params_Type); - Info.Subprg_Params_Ptr := - New_Access_Type (Info.Subprg_Params_Type); - New_Type_Decl (Create_Identifier ("PARAMSPTR"), - Info.Subprg_Params_Ptr); - else - Info.Subprg_Params_Type := O_Tnode_Null; - Info.Subprg_Params_Ptr := O_Tnode_Null; - end if; - Start_Procedure_Decl (Interface_List, Id, Storage); if Info.Subprg_Params_Type /= O_Tnode_Null then @@ -349,6 +362,12 @@ package body Trans.Chap2 is Spec : constant Iir := Get_Subprogram_Specification (Subprg); Info : constant Ortho_Info_Acc := Get_Info (Spec); + -- True if the subprogram is suspendable (can be true only for + -- procedures). + Has_Suspend : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Procedure_Declaration + and then Get_Suspend_Flag (Spec); + Old_Subprogram : Iir; Mark : Id_Mark_Type; Final : Boolean; @@ -390,39 +409,49 @@ package body Trans.Chap2 is Push_Subprg_Identifier (Spec, Mark); Restore_Local_Identifier (Info.Subprg_Local_Id); - if Has_Nested then + if Has_Nested or else Has_Suspend then -- Unnest subprograms. -- Create an instance for the local declarations. Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); Add_Subprg_Instance_Field (Upframe_Field); if Info.Subprg_Params_Ptr /= O_Tnode_Null then + -- Field for the parameters structure Info.Subprg_Params_Var := - Create_Var (Create_Var_Identifier ("RESULT"), + Create_Var (Create_Var_Identifier ("PARAMS"), Info.Subprg_Params_Ptr); + else + -- Create fields for parameters. + -- FIXME: do it only if they are referenced in nested + -- subprograms. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + Inter_Info.Interface_Field := + Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inter), + Inter_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + end; end if; - -- Create fields for parameters. - -- FIXME: do it only if they are referenced in nested - -- subprograms. - declare - Inter : Iir; - Inter_Info : Inter_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Inter_Info := Get_Info (Inter); - if Inter_Info.Interface_Node /= O_Dnode_Null then - Inter_Info.Interface_Field := - Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Inter), - Inter_Info.Interface_Type); - end if; - Inter := Get_Chain (Inter); - end loop; - end; - Chap4.Translate_Declaration_Chain (Subprg); + + if Has_Suspend then + -- Add declarations for statements (iterator, call) and state. + Chap4.Translate_Statements_Chain_State_Declaration + (Get_Sequential_Statement_Chain (Subprg), + Info.Subprg_Locvars_Scope'Access); + Add_Scope_Field (Wki_Locvars, Info.Subprg_Locvars_Scope); + end if; + Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); New_Type_Decl (Create_Identifier ("_FRAMETYPE"), @@ -466,18 +495,52 @@ package body Trans.Chap2 is -- There is a local scope for temporaries. Open_Local_Temp; - if not Has_Nested then + if not Has_Suspend and not Has_Nested then Chap4.Translate_Declaration_Chain (Subprg); Rtis.Generate_Subprogram_Body (Subprg); Chap4.Translate_Declaration_Chain_Subprograms (Subprg); else - New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, - Get_Scope_Type (Info.Subprg_Frame_Scope)); - New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), O_Storage_Local, Frame_Ptr_Type); - New_Assign_Stmt (New_Obj (Frame_Ptr), - New_Address (New_Obj (Frame), Frame_Ptr_Type)); + + if Has_Suspend then + New_Assign_Stmt + (New_Obj (Frame_Ptr), + New_Convert_Ov (New_Value_Selected_Acc_Value + (New_Obj (Info.Res_Interface), + Info.Subprg_Locvars_Field), + Frame_Ptr_Type)); + + Chap8.State_Entry (Info); + + -- Initial state: allocate frame. + New_Assign_Stmt + (New_Obj (Frame_Ptr), + Helpers2.Gen_Alloc + (Alloc_Return, + New_Lit + (New_Sizeof (Get_Scope_Type (Info.Subprg_Frame_Scope), + Ghdl_Index_Type)), + Frame_Ptr_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Info.Res_Interface), + Info.Subprg_Locvars_Field), + New_Convert_Ov (New_Obj_Value (Frame_Ptr), + Ghdl_Ptr_Type)); + + -- Allocate the return state. This IS NOT AN ASSERTION as the + -- State_Allocate function has a side-effect. + if Chap8.State_Allocate /= Chap8.State_Return then + raise Internal_Error; + end if; + else + -- Allocate the frame by declaring a local variable. + New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, + Get_Scope_Type (Info.Subprg_Frame_Scope)); + + New_Assign_Stmt (New_Obj (Frame_Ptr), + New_Address (New_Obj (Frame), Frame_Ptr_Type)); + end if; -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); @@ -487,7 +550,7 @@ package body Trans.Chap2 is (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); if Info.Subprg_Params_Type /= O_Tnode_Null then - -- Initialize the RESULT field + -- Initialize the PARAMS field New_Assign_Stmt (Get_Var (Info.Subprg_Params_Var), New_Obj_Value (Info.Res_Interface)); -- Do not reference the RESULT field in the subprogram body, @@ -497,42 +560,43 @@ package body Trans.Chap2 is end if; -- Copy parameters to FRAME. - declare - Inter : Iir; - Inter_Info : Inter_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Inter_Info := Get_Info (Inter); - if Inter_Info.Interface_Node /= O_Dnode_Null then - New_Assign_Stmt - (New_Selected_Element (New_Obj (Frame), - Inter_Info.Interface_Field), - New_Obj_Value (Inter_Info.Interface_Node)); - - -- Forget the reference to the field in FRAME, so that - -- this subprogram will directly reference the parameter - -- (and not its copy in the FRAME). - Inter_Info.Interface_Field := O_Fnode_Null; - end if; - Inter := Get_Chain (Inter); - end loop; - end; + if Info.Subprg_Params_Ptr = O_Tnode_Null then + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Frame), + Inter_Info.Interface_Field), + New_Obj_Value (Inter_Info.Interface_Node)); + + -- Forget the reference to the field in FRAME, so that + -- this subprogram will directly reference the parameter + -- (and not its copy in the FRAME). + Inter_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + end if; + end if; + + Is_Prot := Is_Subprogram_Method (Spec); + if Is_Prot then + -- Lock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Enter); end if; Chap4.Elab_Declaration_Chain (Subprg, Final); - -- If finalization is required, create a dummy loop around the - -- body and convert returns into exit out of this loop. - -- If the subprogram is a function, also create a variable for the - -- result. - Is_Prot := Is_Subprogram_Method (Spec); + -- If finalization is required and if the subprogram is a function, + -- create a variable for the result. if Final or Is_Prot then - if Is_Prot then - -- Lock the object. - Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), - Ghdl_Protected_Enter); - end if; Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); if Is_Ortho_Func then New_Var_Decl @@ -540,6 +604,11 @@ package body Trans.Chap2 is O_Storage_Local, Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); end if; + end if; + + -- If finalization is required, create a dummy loop around the + -- body and convert returns into exit out of this loop. + if not Has_Suspend and then (Final or Is_Prot) then Start_Loop_Stmt (Info.Subprg_Exit); end if; @@ -549,10 +618,14 @@ package body Trans.Chap2 is (Get_Sequential_Statement_Chain (Subprg)); Current_Subprogram := Old_Subprogram; - if Final or Is_Prot then + if Has_Suspend or Final or Is_Prot then -- Create a barrier to catch missing return statement. if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then - New_Exit_Stmt (Info.Subprg_Exit); + if Has_Suspend then + Chap8.State_Jump (Chap8.State_Return); + else + New_Exit_Stmt (Info.Subprg_Exit); + end if; else if not Has_Return then -- Missing return @@ -560,7 +633,11 @@ package body Trans.Chap2 is (Subprg, Chap6.Prg_Err_Missing_Return); end if; end if; - Finish_Loop_Stmt (Info.Subprg_Exit); + if Has_Suspend then + Chap8.State_Start (Chap8.State_Return); + else + Finish_Loop_Stmt (Info.Subprg_Exit); + end if; Chap4.Final_Declaration_Chain (Subprg, False); if Is_Prot then @@ -568,6 +645,12 @@ package body Trans.Chap2 is Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), Ghdl_Protected_Leave); end if; + + if Has_Suspend then + Chap8.State_Suspend (Chap8.State_Return); + Chap8.State_Leave (Spec); + end if; + if Is_Ortho_Func then New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); end if; @@ -896,6 +979,9 @@ package body Trans.Chap2 is Subprg_Params_Var => Instantiate_Var (Src.Subprg_Params_Var), Subprg_Params_Type => Src.Subprg_Params_Type, Subprg_Params_Ptr => Src.Subprg_Params_Ptr, + Subprg_State_Field => Src.Subprg_State_Field, + Subprg_Locvars_Field => Src.Subprg_Locvars_Field, + Subprg_Locvars_Scope => Src.Subprg_Locvars_Scope, Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, Subprg_Instance => Instantiate_Subprg_Instance (Src.Subprg_Instance), diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index 6ab2802..fd946d1 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -2641,6 +2641,20 @@ package body Trans.Chap3 is end if; end Get_Object_Size; + procedure Copy_Bounds (Dest : O_Enode; Src : O_Enode; Obj_Type : Iir) + is + Tinfo : constant Type_Info_Acc := Get_Info (Obj_Type); + begin + Gen_Memcpy + (Dest, Src, + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, Ghdl_Index_Type))); + end Copy_Bounds; + + procedure Copy_Bounds (Dest : Mnode; Src : Mnode; Obj_Type : Iir) is + begin + Copy_Bounds (M2Addr (Dest), M2Addr (Src), Obj_Type); + end Copy_Bounds; + procedure Translate_Object_Allocation (Res : in out Mnode; Alloc_Kind : Allocation_Kind; @@ -2660,10 +2674,7 @@ package body Trans.Chap3 is Dinfo.T.Bounds_Ptr_Type)); -- Copy bounds to the allocated area. - Gen_Memcpy - (M2Addr (Chap3.Get_Array_Bounds (Res)), - M2Addr (Bounds), - New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); + Copy_Bounds (Chap3.Get_Array_Bounds (Res), Bounds, Obj_Type); -- Allocate base. Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type); diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads index 459b1c8..f7a23fd 100644 --- a/src/vhdl/translate/trans-chap3.ads +++ b/src/vhdl/translate/trans-chap3.ads @@ -180,6 +180,9 @@ package Trans.Chap3 is -- Performs deallocation of PARAM (the parameter of a deallocate call). procedure Translate_Object_Deallocation (Param : Iir); + -- Copy bounds from SRC to DEST. + procedure Copy_Bounds (Dest : O_Enode; Src : O_Enode; Obj_Type : Iir); + -- Allocate an object of type OBJ_TYPE and set RES. -- RES must be a stable access of type ortho_ptr_type. -- For an unconstrained array, BOUNDS is a pointer to the boundaries of diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index 70f4165..a33f9ca 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -20,12 +20,14 @@ with Errorout; use Errorout; with Files_Map; with Iirs_Utils; use Iirs_Utils; with Std_Package; use Std_Package; +with Canon; with Translation; use Translation; with Trans.Chap2; with Trans.Chap3; with Trans.Chap5; with Trans.Chap6; with Trans.Chap7; +with Trans.Chap8; with Trans.Chap9; with Trans.Chap14; with Trans.Rtis; @@ -462,9 +464,8 @@ package body Trans.Chap4 is if Type_Info.Type_Mode = Type_Mode_Fat_Array then -- Allocate. declare - Aggr_Type : Iir; + Aggr_Type : constant Iir := Get_Type (Value); begin - Aggr_Type := Get_Type (Value); Chap3.Create_Array_Subtype (Aggr_Type); Name_Node := Stabilize (Name); New_Assign_Stmt @@ -2025,6 +2026,157 @@ package body Trans.Chap4 is end loop; end Translate_Declaration_Chain; + procedure Translate_Statements_Chain_State_Declaration + (Stmts : Iir; State_Scope : Var_Scope_Acc) + is + Num : Nat32; + Mark : Id_Mark_Type; + Locvar_Id : O_Ident; + Els : O_Element_List; + + procedure Push_Prefix (Really_Push : Boolean := True) + is + Num_Img : String := Nat32'Image (Num); + begin + Num_Img (Num_Img'First) := 'S'; + Locvar_Id := Get_Identifier (Num_Img); + Num := Num + 1; + if Really_Push then + Push_Identifier_Prefix (Mark, Num_Img); + end if; + end Push_Prefix; + + procedure Pop_Prefix (Scope : in out Var_Scope_Type; + Really_Push : Boolean := True) + is + Locvar_Field : O_Fnode; + begin + if Really_Push then + Pop_Identifier_Prefix (Mark); + end if; + + New_Union_Field + (Els, Locvar_Field, Locvar_Id, Get_Scope_Type (Scope)); + Set_Scope_Via_Field (Scope, Locvar_Field, State_Scope); + end Pop_Prefix; + + Info : Ortho_Info_Acc; + Stmt : Iir; + Chain : Iir; + Scope_Type : O_Tnode; + begin + Stmt := Stmts; + + Start_Union_Type (Els); + Num := 0; + + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_If_Statement => + if Get_Suspend_Flag (Stmt) then + Chain := Stmt; + while Chain /= Null_Iir loop + Push_Prefix; + + Info := Add_Info (Chain, Kind_Locvar_State); + + Translate_Statements_Chain_State_Declaration + (Get_Sequential_Statement_Chain (Chain), + Info.Locvar_Scope'Access); + + Pop_Prefix (Info.Locvar_Scope); + + Chain := Get_Else_Clause (Chain); + end loop; + end if; + + when Iir_Kind_Case_Statement => + if Get_Suspend_Flag (Stmt) then + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + while Chain /= Null_Iir loop + if not Get_Same_Alternative_Flag (Chain) then + Push_Prefix; + + Info := Add_Info (Chain, Kind_Locvar_State); + + Translate_Statements_Chain_State_Declaration + (Get_Associated_Chain (Chain), + Info.Locvar_Scope'Access); + + Pop_Prefix (Info.Locvar_Scope); + end if; + Chain := Get_Chain (Chain); + end loop; + end if; + + when Iir_Kind_While_Loop_Statement => + if Get_Suspend_Flag (Stmt) then + Push_Prefix; + + Info := Add_Info (Stmt, Kind_Loop_State); + + Translate_Statements_Chain_State_Declaration + (Get_Sequential_Statement_Chain (Stmt), + Info.Loop_Locvar_Scope'Access); + + Pop_Prefix (Info.Loop_Locvar_Scope); + end if; + + when Iir_Kind_For_Loop_Statement => + if Get_Suspend_Flag (Stmt) then + Push_Prefix; + + Info := Add_Info (Stmt, Kind_Loop_State); + + Push_Instance_Factory (Info.Loop_State_Scope'Access); + + Chap8.Translate_For_Loop_Statement_Declaration (Stmt); + + Translate_Statements_Chain_State_Declaration + (Get_Sequential_Statement_Chain (Stmt), + Info.Loop_Locvar_Scope'Access); + + Add_Scope_Field (Wki_Locvars, Info.Loop_Locvar_Scope); + + Pop_Instance_Factory (Info.Loop_State_Scope'Access); + + New_Type_Decl (Create_Identifier ("FORTYPE"), + Get_Scope_Type (Info.Loop_State_Scope)); + + Pop_Prefix (Info.Loop_State_Scope); + end if; + + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + begin + Canon.Canon_Subprogram_Call (Call); + Update_Node_Infos; + + if Get_Suspend_Flag (Imp) then + Push_Prefix; + + Info := Add_Info (Call, Kind_Call); + + Chap8.Translate_Procedure_Call_State (Call); + + Pop_Prefix (Info.Call_State_Scope); + end if; + end; + when others => + null; + end case; + Stmt := Get_Chain (Stmt); + end loop; + + Finish_Union_Type (Els, Scope_Type); + + New_Type_Decl + (Create_Identifier ("LOCVARTYPE"), Scope_Type); + Create_Union_Scope (State_Scope.all, Scope_Type); + end Translate_Statements_Chain_State_Declaration; + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) is El : Iir; diff --git a/src/vhdl/translate/trans-chap4.ads b/src/vhdl/translate/trans-chap4.ads index 6f9b8ae..317d103 100644 --- a/src/vhdl/translate/trans-chap4.ads +++ b/src/vhdl/translate/trans-chap4.ads @@ -31,6 +31,10 @@ package Trans.Chap4 is -- Translate declarations, except subprograms spec and bodies. procedure Translate_Declaration_Chain (Parent : Iir); + -- Create declarations for statements STMTS to support resume. + procedure Translate_Statements_Chain_State_Declaration + (Stmts : Iir; State_Scope : Var_Scope_Acc); + -- Translate subprograms in declaration chain of PARENT. procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index 9640f44..96453f2 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -739,7 +739,7 @@ package body Trans.Chap6 is function Translate_Interface_Name (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) - return Mnode + return Mnode is Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); begin @@ -1016,7 +1016,7 @@ package body Trans.Chap6 is Assoc_Chain := Get_Parameter_Association_Chain (Name); Obj := Get_Method_Object (Name); return E2M - (Chap8.Translate_Subprogram_Call (Imp, Assoc_Chain, Obj), + (Chap8.Translate_Subprogram_Call (Name, Assoc_Chain, Obj), Type_Info, Mode_Value); end if; end; diff --git a/src/vhdl/translate/trans-chap6.ads b/src/vhdl/translate/trans-chap6.ads index 5a11fb6..3ce60c3 100644 --- a/src/vhdl/translate/trans-chap6.ads +++ b/src/vhdl/translate/trans-chap6.ads @@ -57,6 +57,7 @@ package Trans.Chap6 is Prg_Err_Dummy_Config : constant Natural := 3; Prg_Err_No_Choice : constant Natural := 4; Prg_Err_Bad_Choice : constant Natural := 5; + Prg_Err_Unreach_State : constant Natural := 6; procedure Gen_Program_Error (Loc : Iir; Code : Natural); -- Generate code to emit a failure if COND is TRUE, indicating an diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 7f12ff1..081526b 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -700,8 +700,10 @@ package body Trans.Chap7 is end Translate_Range_Length; function Translate_Operator_Function_Call - (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) return O_Enode + (Call : Iir; Left : Iir; Right : Iir; Res_Type : Iir) return O_Enode is + Imp : constant Iir := Get_Implementation (Call); + function Create_Assoc (Actual : Iir; Formal : Iir) return Iir is R : Iir; @@ -728,7 +730,7 @@ package body Trans.Chap7 is Set_Chain (El_L, El_R); end if; - Res := Chap8.Translate_Subprogram_Call (Imp, El_L, Null_Iir); + Res := Chap8.Translate_Subprogram_Call (Call, El_L, Null_Iir); Free_Iir (El_L); if Right /= Null_Iir then @@ -1997,13 +1999,11 @@ package body Trans.Chap7 is end Translate_Predefined_Std_Ulogic_Array_Match; function Translate_Predefined_Operator - (Imp : Iir_Function_Declaration; - Left, Right : Iir; - Res_Type : Iir; - Loc : Iir) + (Expr : Iir_Function_Declaration; Left, Right : Iir; Res_Type : Iir) return O_Enode is - Kind : constant Iir_Predefined_Functions := + Imp : constant Iir := Get_Implementation (Expr); + Kind : constant Iir_Predefined_Functions := Get_Implicit_Definition (Imp); Left_Tree : O_Enode; Right_Tree : O_Enode; @@ -2049,40 +2049,40 @@ package body Trans.Chap7 is -- same for the result. when Iir_Predefined_TF_Array_Element_And => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_And => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Expr); when Iir_Predefined_TF_Array_Element_Or => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_Or => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Expr); when Iir_Predefined_TF_Array_Element_Nand => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_Nand => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Expr); when Iir_Predefined_TF_Array_Element_Nor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_Nor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Expr); when Iir_Predefined_TF_Array_Element_Xor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_Xor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Expr); when Iir_Predefined_TF_Array_Element_Xnor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); + (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Expr); when Iir_Predefined_TF_Element_Array_Xnor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); + (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Expr); -- Avoid implicit conversion of the array parameters to the -- unbounded type for optimizing purpose. @@ -2180,7 +2180,7 @@ package body Trans.Chap7 is raise Internal_Error; end case; Res := Translate_Implicit_Conv - (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc); + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Expr); return Res; end if; @@ -2205,7 +2205,7 @@ package body Trans.Chap7 is | Iir_Predefined_Floating_Identity | Iir_Predefined_Physical_Identity => return Translate_Implicit_Conv - (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc); + (Left_Tree, Left_Type, Res_Type, Mode_Value, Expr); when Iir_Predefined_Access_Equality | Iir_Predefined_Access_Inequality => @@ -2449,21 +2449,21 @@ package body Trans.Chap7 is when Iir_Predefined_Array_Minimum => return Translate_Predefined_Array_Min_Max (True, Left_Tree, Right_Tree, Left_Type, Right_Type, - Res_Type, Imp, Loc); + Res_Type, Imp, Expr); when Iir_Predefined_Array_Maximum => return Translate_Predefined_Array_Min_Max (False, Left_Tree, Right_Tree, Left_Type, Right_Type, - Res_Type, Imp, Loc); + Res_Type, Imp, Expr); when Iir_Predefined_Integer_To_String => case Get_Info (Left_Type).Type_Mode is when Type_Mode_I32 => return Translate_To_String - (Ghdl_To_String_I32, Res_Type, Loc, + (Ghdl_To_String_I32, Res_Type, Expr, New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); when Type_Mode_I64 => return Translate_To_String - (Ghdl_To_String_I64, Res_Type, Loc, + (Ghdl_To_String_I64, Res_Type, Expr, New_Convert_Ov (Left_Tree, Ghdl_I64_Type)); when others => raise Internal_Error; @@ -2475,7 +2475,7 @@ package body Trans.Chap7 is -- So special case for character. if Get_Base_Type (Left_Type) = Character_Type_Definition then return Translate_To_String - (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); + (Ghdl_To_String_Char, Res_Type, Expr, Left_Tree); end if; -- LRM08 5.7 String representations @@ -2498,23 +2498,23 @@ package body Trans.Chap7 is raise Internal_Error; end case; return Translate_To_String - (Subprg, Res_Type, Loc, + (Subprg, Res_Type, Expr, New_Convert_Ov (Left_Tree, Conv), New_Lit (Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti))); end; when Iir_Predefined_Floating_To_String => return Translate_To_String - (Ghdl_To_String_F64, Res_Type, Loc, + (Ghdl_To_String_F64, Res_Type, Expr, New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); when Iir_Predefined_Real_To_String_Digits => return Translate_To_String - (Ghdl_To_String_F64_Digits, Res_Type, Loc, + (Ghdl_To_String_F64_Digits, Res_Type, Expr, New_Convert_Ov (Left_Tree, Ghdl_Real_Type), New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); when Iir_Predefined_Real_To_String_Format => return Translate_To_String - (Ghdl_To_String_F64_Format, Res_Type, Loc, + (Ghdl_To_String_F64_Format, Res_Type, Expr, New_Convert_Ov (Left_Tree, Ghdl_Real_Type), Right_Tree); when Iir_Predefined_Physical_To_String => @@ -2533,23 +2533,23 @@ package body Trans.Chap7 is raise Internal_Error; end case; return Translate_To_String - (Subprg, Res_Type, Loc, + (Subprg, Res_Type, Expr, New_Convert_Ov (Left_Tree, Conv), New_Lit (Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti))); end; when Iir_Predefined_Time_To_String_Unit => return Translate_To_String - (Ghdl_Time_To_String_Unit, Res_Type, Loc, + (Ghdl_Time_To_String_Unit, Res_Type, Expr, Left_Tree, Right_Tree, New_Lit (Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti))); when Iir_Predefined_Bit_Vector_To_Ostring => return Translate_Bv_To_String - (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); + (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Expr); when Iir_Predefined_Bit_Vector_To_Hstring => return Translate_Bv_To_String - (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); + (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Expr); when Iir_Predefined_Array_Char_To_String => declare El_Type : constant Iir := Get_Element_Subtype (Left_Type); @@ -2569,7 +2569,7 @@ package body Trans.Chap7 is raise Internal_Error; end case; return Translate_To_String - (Subprg, Res_Type, Loc, + (Subprg, Res_Type, Expr, New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), Ghdl_Ptr_Type), Chap3.Get_Array_Length (Arg, Left_Type), @@ -3923,19 +3923,19 @@ package body Trans.Chap7 is Imp := Get_Implementation (Expr); if Is_Implicit_Subprogram (Imp) then return Translate_Predefined_Operator - (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr); + (Expr, Get_Left (Expr), Get_Right (Expr), Res_Type); else return Translate_Operator_Function_Call - (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type); + (Expr, Get_Left (Expr), Get_Right (Expr), Res_Type); end if; when Iir_Kinds_Monadic_Operator => Imp := Get_Implementation (Expr); if Is_Implicit_Subprogram (Imp) then return Translate_Predefined_Operator - (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr); + (Expr, Get_Operand (Expr), Null_Iir, Res_Type); else return Translate_Operator_Function_Call - (Imp, Get_Operand (Expr), Null_Iir, Res_Type); + (Expr, Get_Operand (Expr), Null_Iir, Res_Type); end if; when Iir_Kind_Function_Call => Imp := Get_Implementation (Expr); @@ -3960,13 +3960,14 @@ package body Trans.Chap7 is end if; end if; return Translate_Predefined_Operator - (Imp, Left, Right, Res_Type, Expr); + (Expr, Left, Right, Res_Type); end; else Canon.Canon_Subprogram_Call (Expr); + Trans.Update_Node_Infos; Assoc_Chain := Get_Parameter_Association_Chain (Expr); Res := Chap8.Translate_Subprogram_Call - (Imp, Assoc_Chain, Get_Method_Object (Expr)); + (Expr, Assoc_Chain, Get_Method_Object (Expr)); Expr_Type := Get_Return_Type (Imp); end if; end; diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index a30a68e..d7b839d 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -39,6 +39,134 @@ with Trans.Foreach_Non_Composite; package body Trans.Chap8 is use Trans.Helpers; + -- The LOCAL_STATE is a local variable read from the frame at entry and + -- written before return. The value INITIAL_STATE (0) is the initial + -- state. For processes, this is the state for the first statement. For + -- subprograms, this is the state at call, before dynamic elaboration of + -- local declarations. + -- Subprograms have more special values: + -- 1: The return state. Finalization is performed. + Local_State : O_Dnode := O_Dnode_Null; + + Initial_State : constant State_Type := 0; + -- Return_State : constant State_Value_Type := 1; + + -- Next value available. + State_Next : State_Type := Initial_State; + + -- Info node to which the state variable is attached. Used to set and save + -- the state variable. + State_Info : Ortho_Info_Acc := null; + + -- Statements construct for the state machine. The generated code is: + -- local var STATE: index_type; + -- begin + -- STATE := FRAME.all.STATE; + -- loop + -- case STATE is + -- when 0 => ... + -- when 1 => ... + -- ... + -- end case; + -- end loop; + -- end; + State_Case : Ortho_Nodes.O_Case_Block; + State_Loop : Ortho_Nodes.O_Snode; + + function Get_State_Var (Info : Ortho_Info_Acc) return O_Lnode is + begin + case Info.Kind is + when Kind_Process => + return Get_Var (Info.Process_State); + when Kind_Subprg => + return New_Selected_Acc_Value + (New_Obj (Info.Res_Interface), Info.Subprg_State_Field); + when others => + raise Internal_Error; + end case; + end Get_State_Var; + + procedure State_Entry (Info : Ortho_Info_Acc) is + begin + -- Not reentrant. + pragma Assert (not State_Enabled); + + State_Info := Info; + + -- For optimization, create a copy of the STATE variable. + New_Var_Decl (Local_State, Get_Identifier ("STATE"), + O_Storage_Local, Ghdl_Index_Type); + + -- Initialize it from the frame. + New_Assign_Stmt (New_Obj (Local_State), + New_Value (Get_State_Var (Info))); + + Start_Loop_Stmt (State_Loop); + Start_Case_Stmt (State_Case, New_Obj_Value (Local_State)); + + State_Start (0); + State_Next := 0; + end State_Entry; + + procedure State_Leave (Parent : Iir) is + begin + pragma Assert (State_Enabled); + pragma Assert (Get_Info (Parent) = State_Info); + + if State_Debug then + Start_Choice (State_Case); + New_Default_Choice (State_Case); + Finish_Choice (State_Case); + Chap6.Gen_Program_Error (Parent, Chap6.Prg_Err_Unreach_State); + end if; + + Finish_Case_Stmt (State_Case); + Finish_Loop_Stmt (State_Loop); + Local_State := O_Dnode_Null; + State_Info := null; + end State_Leave; + + function State_Enabled return Boolean is + begin + return Local_State /= O_Dnode_Null; + end State_Enabled; + + function State_Allocate return State_Type is + begin + State_Next := State_Next + 1; + return State_Next; + end State_Allocate; + + function State_To_Lit (State : State_Type) return O_Cnode is + begin + return New_Index_Lit (Unsigned_64 (State)); + end State_To_Lit; + + procedure State_Start (State : State_Type) is + begin + Start_Choice (State_Case); + New_Expr_Choice (State_Case, State_To_Lit (State)); + Finish_Choice (State_Case); + end State_Start; + + procedure State_Jump (Next_State : State_Type) is + begin + New_Assign_Stmt (New_Obj (Local_State), + New_Lit (State_To_Lit (Next_State))); + end State_Jump; + + procedure State_Jump_Force is + begin + New_Next_Stmt (State_Loop); + end State_Jump_Force; + + procedure State_Suspend (Next_State : State_Type) is + begin + New_Assign_Stmt (Get_State_Var (State_Info), + New_Lit (State_To_Lit (Next_State))); + New_Return_Stmt; + end State_Suspend; + procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) is Subprg_Info : constant Ortho_Info_Acc := @@ -68,7 +196,13 @@ package body Trans.Chap8 is begin if Expr = Null_Iir then -- Return in a procedure. - Gen_Return; + if Get_Suspend_Flag (Chap2.Current_Subprogram) then + State_Jump (State_Return); + State_Jump_Force; + else + Gen_Return; + end if; + return; end if; @@ -83,7 +217,8 @@ package body Trans.Chap8 is R : O_Enode; begin -- Always uses a temporary in case of the return expression - -- uses secondary stack. + -- uses secondary stack. This can happen in constructs like: + -- return my_func (param)(index); -- FIXME: don't use the temp if not required. R := Chap7.Translate_Expression (Expr, Ret_Type); if Has_Stack2_Mark @@ -144,16 +279,68 @@ package body Trans.Chap8 is Close_Temp; Gen_Return; end; - when Type_Mode_File => - -- FIXME: Is it possible ? - Error_Kind ("translate_return_statement", Ret_Type); - when Type_Mode_Unknown + when Type_Mode_File + | Type_Mode_Unknown | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Return_Statement; - procedure Translate_If_Statement (Stmt : Iir) + procedure Translate_If_Statement_State_Jumps + (Stmt : Iir; Fall_State : State_Type) + is + Blk : O_If_Block; + Else_Clause : Iir; + begin + Start_If_Stmt + (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); + State_Jump (State_Allocate); + New_Else_Stmt (Blk); + Else_Clause := Get_Else_Clause (Stmt); + if Else_Clause = Null_Iir then + State_Jump (Fall_State); + else + if Get_Condition (Else_Clause) = Null_Iir then + State_Jump (State_Allocate); + else + Open_Temp; + Translate_If_Statement_State_Jumps (Else_Clause, Fall_State); + Close_Temp; + end if; + end if; + Finish_If_Stmt (Blk); + end Translate_If_Statement_State_Jumps; + + procedure Translate_If_Statement_State (Stmt : Iir) + is + Fall_State : State_Type; + Next_State : State_Type; + Branch : Iir; + begin + Fall_State := State_Allocate; + Next_State := Fall_State; + + -- Generate the jumps. + Open_Temp; + Translate_If_Statement_State_Jumps (Stmt, Fall_State); + Close_Temp; + + -- Generate statements. + Branch := Stmt; + loop + Next_State := Next_State + 1; + State_Start (Next_State); + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Branch)); + State_Jump (Fall_State); + + Branch := Get_Else_Clause (Branch); + exit when Branch = Null_Iir; + end loop; + + State_Start (Fall_State); + end Translate_If_Statement_State; + + procedure Translate_If_Statement_Direct (Stmt : Iir) is Blk : O_If_Block; Else_Clause : Iir; @@ -171,11 +358,20 @@ package body Trans.Chap8 is (Get_Sequential_Statement_Chain (Else_Clause)); else Open_Temp; - Translate_If_Statement (Else_Clause); + Translate_If_Statement_Direct (Else_Clause); Close_Temp; end if; end if; Finish_If_Stmt (Blk); + end Translate_If_Statement_Direct; + + procedure Translate_If_Statement (Stmt : Iir) is + begin + if Get_Suspend_Flag (Stmt) then + Translate_If_Statement_State (Stmt); + else + Translate_If_Statement_Direct (Stmt); + end if; end Translate_If_Statement; function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) @@ -187,22 +383,12 @@ package body Trans.Chap8 is end Get_Range_Ptr_Field_Value; -- Inc or dec ITERATOR according to DIR. - procedure Gen_Update_Iterator (Iterator : O_Dnode; - Dir : Iir_Direction; - Val : Unsigned_64; - Itype : Iir) + procedure Gen_Update_Iterator_Common (Val : Unsigned_64; + Itype : Iir; + V : out O_Enode) is - Op : ON_Op_Kind; - Base_Type : Iir; - V : O_Enode; + Base_Type : constant Iir := Get_Base_Type (Itype); begin - case Dir is - when Iir_To => - Op := ON_Add_Ov; - when Iir_Downto => - Op := ON_Sub_Ov; - end case; - Base_Type := Get_Base_Type (Itype); case Get_Kind (Base_Type) is when Iir_Kind_Integer_Type_Definition => V := New_Lit @@ -224,59 +410,99 @@ package body Trans.Chap8 is when others => Error_Kind ("gen_update_iterator", Base_Type); end case; + end Gen_Update_Iterator_Common; + + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir) + is + Op : ON_Op_Kind; + V : O_Enode; + begin + case Dir is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + Gen_Update_Iterator_Common (Val, Itype, V); New_Assign_Stmt (New_Obj (Iterator), New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); end Gen_Update_Iterator; - type For_Loop_Data is record - Iterator : Iir_Iterator_Declaration; - Stmt : Iir_For_Loop_Statement; - -- If around the loop, to check if the loop must be executed. - If_Blk : O_If_Block; - Label_Next, Label_Exit : O_Snode; - -- Right bound of the iterator, used only if the iterator is a - -- range expression. - O_Right : O_Dnode; - -- Range variable of the iterator, used only if the iterator is not - -- a range expression. - O_Range : O_Dnode; - end record; + procedure Gen_Update_Iterator (Iterator : Var_Type; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir) + is + Op : ON_Op_Kind; + V : O_Enode; + begin + case Dir is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + Gen_Update_Iterator_Common (Val, Itype, V); + New_Assign_Stmt (Get_Var (Iterator), + New_Dyadic_Op (Op, New_Value (Get_Var (Iterator)), V)); + end Gen_Update_Iterator; - procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; - Stmt : Iir_For_Loop_Statement; - Data : out For_Loop_Data) + procedure Translate_For_Loop_Statement_Declaration (Stmt : Iir) is - Iter_Type : Iir; - Iter_Base_Type : Iir; - Var_Iter : Var_Type; - Constraint : Iir; - Cond : O_Enode; - Dir : Iir_Direction; - Iter_Type_Info : Ortho_Info_Acc; - Op : ON_Op_Kind; + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Type_Info : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Iter_Type)); + Constraint : constant Iir := Get_Range_Constraint (Iter_Type); + It_Info : Ortho_Info_Acc; begin - -- Initialize DATA. - Data.Iterator := Iterator; - Data.Stmt := Stmt; + -- Iterator range. + Chap3.Translate_Object_Subtype (Iterator, False); - Iter_Type := Get_Type (Iterator); - Iter_Base_Type := Get_Base_Type (Iter_Type); - Iter_Type_Info := Get_Info (Iter_Base_Type); - Var_Iter := Get_Info (Iterator).Iterator_Var; + -- Iterator variable. + It_Info := Add_Info (Iterator, Kind_Iterator); + It_Info.Iterator_Var := Create_Var + (Create_Var_Identifier (Iterator), + Iter_Type_Info.Ortho_Type (Mode_Value), + O_Storage_Local); - Open_Temp; + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + It_Info.Iterator_Right := Create_Var + (Create_Var_Identifier ("IT_RIGHT"), + Iter_Type_Info.Ortho_Type (Mode_Value), + O_Storage_Local); + else + It_Info.Iterator_Range := Create_Var + (Create_Var_Identifier ("IT_RANGE"), + Iter_Type_Info.T.Range_Ptr_Type, + O_Storage_Local); + end if; + end Translate_For_Loop_Statement_Declaration; - Constraint := Get_Range_Constraint (Iter_Type); + procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; + Cond : out O_Enode) + is + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Ortho_Info_Acc := Get_Info (Iter_Base_Type); + It_Info : constant Ortho_Info_Acc := Get_Info (Iterator); + Constraint : constant Iir := Get_Range_Constraint (Iter_Type); + Dir : Iir_Direction; + Op : ON_Op_Kind; + begin if Get_Kind (Constraint) = Iir_Kind_Range_Expression then New_Assign_Stmt - (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left - (Constraint, Iter_Base_Type)); + (Get_Var (It_Info.Iterator_Var), + Chap7.Translate_Range_Expression_Left (Constraint, + Iter_Base_Type)); Dir := Get_Direction (Constraint); - Data.O_Right := Create_Temp - (Iter_Type_Info.Ortho_Type (Mode_Value)); New_Assign_Stmt - (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right - (Constraint, Iter_Base_Type)); + (Get_Var (It_Info.Iterator_Right), + Chap7.Translate_Range_Expression_Right (Constraint, + Iter_Base_Type)); case Dir is when Iir_To => Op := ON_Le; @@ -285,181 +511,278 @@ package body Trans.Chap8 is end case; -- Check for at least one iteration. Cond := New_Compare_Op - (Op, New_Value (Get_Var (Var_Iter)), - New_Obj_Value (Data.O_Right), + (Op, New_Value (Get_Var (It_Info.Iterator_Var)), + New_Value (Get_Var (It_Info.Iterator_Right)), Ghdl_Bool_Type); else - Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); - New_Assign_Stmt (New_Obj (Data.O_Range), + New_Assign_Stmt (Get_Var (It_Info.Iterator_Range), New_Address (Chap7.Translate_Range - (Constraint, Iter_Base_Type), - Iter_Type_Info.T.Range_Ptr_Type)); + (Constraint, Iter_Base_Type), + Iter_Type_Info.T.Range_Ptr_Type)); New_Assign_Stmt - (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value - (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); - -- Before starting the loop, check wether there will be at least + (Get_Var (It_Info.Iterator_Var), + Get_Range_Ptr_Field_Value (Get_Var (It_Info.Iterator_Range), + Iter_Type_Info.T.Range_Left)); + -- Before starting the loop, check whether there will be at least -- one iteration. Cond := New_Compare_Op (ON_Gt, - Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), - Iter_Type_Info.T.Range_Length), + Get_Range_Ptr_Field_Value (Get_Var (It_Info.Iterator_Range), + Iter_Type_Info.T.Range_Length), New_Lit (Ghdl_Index_0), Ghdl_Bool_Type); end if; - - Start_If_Stmt (Data.If_Blk, Cond); - - -- Start loop. - -- There are two blocks: one for the exit, one for the next. - Start_Loop_Stmt (Data.Label_Exit); - Start_Loop_Stmt (Data.Label_Next); - - if Stmt /= Null_Iir then - declare - Loop_Info : Loop_Info_Acc; - begin - Loop_Info := Add_Info (Stmt, Kind_Loop); - Loop_Info.Label_Exit := Data.Label_Exit; - Loop_Info.Label_Next := Data.Label_Next; - end; - end if; end Start_For_Loop; - procedure Finish_For_Loop (Data : in out For_Loop_Data) + procedure Exit_Cond_For_Loop (Iterator : Iir; Cond : out O_Enode) is - Cond : O_Enode; - If_Blk1 : O_If_Block; - Iter_Type : Iir; - Iter_Base_Type : Iir; - Iter_Type_Info : Type_Info_Acc; - Var_Iter : Var_Type; - Constraint : Iir; - Deep_Rng : Iir; - Deep_Reverse : Boolean; + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Ortho_Info_Acc := Get_Info (Iter_Base_Type); + It_Info : constant Ortho_Info_Acc := Get_Info (Iterator); + Constraint : constant Iir := Get_Range_Constraint (Iter_Type); + Val : O_Enode; begin - New_Exit_Stmt (Data.Label_Next); - Finish_Loop_Stmt (Data.Label_Next); - -- Check end of loop. -- Equality is necessary and enough. - Iter_Type := Get_Type (Data.Iterator); - Iter_Base_Type := Get_Base_Type (Iter_Type); - Iter_Type_Info := Get_Info (Iter_Base_Type); - Var_Iter := Get_Info (Data.Iterator).Iterator_Var; - - Constraint := Get_Range_Constraint (Iter_Type); if Get_Kind (Constraint) = Iir_Kind_Range_Expression then - Cond := New_Obj_Value (Data.O_Right); + Val := New_Value (Get_Var (It_Info.Iterator_Right)); else - Cond := Get_Range_Ptr_Field_Value - (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); + Val := Get_Range_Ptr_Field_Value + (Get_Var (It_Info.Iterator_Range), Iter_Type_Info.T.Range_Right); end if; - Gen_Exit_When (Data.Label_Exit, - New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), - Cond, Ghdl_Bool_Type)); + Cond := New_Compare_Op (ON_Eq, + New_Value (Get_Var (It_Info.Iterator_Var)), Val, + Ghdl_Bool_Type); + end Exit_Cond_For_Loop; + procedure Update_For_Loop (Iterator : Iir) + is + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Ortho_Info_Acc := Get_Info (Iter_Base_Type); + It_Info : constant Ortho_Info_Acc := Get_Info (Iterator); + If_Blk1 : O_If_Block; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin -- Update the iterator. Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); if Deep_Rng /= Null_Iir then if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + Gen_Update_Iterator (It_Info.Iterator_Var, + Iir_To, 1, Iter_Base_Type); else - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + Gen_Update_Iterator (It_Info.Iterator_Var, + Iir_Downto, 1, Iter_Base_Type); end if; else Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, - Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), - Iter_Type_Info.T.Range_Dir), + Get_Range_Ptr_Field_Value (Get_Var (It_Info.Iterator_Range), + Iter_Type_Info.T.Range_Dir), New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + Gen_Update_Iterator (It_Info.Iterator_Var, + Iir_To, 1, Iter_Base_Type); New_Else_Stmt (If_Blk1); - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + Gen_Update_Iterator (It_Info.Iterator_Var, + Iir_Downto, 1, Iter_Base_Type); Finish_If_Stmt (If_Blk1); end if; + end Update_For_Loop; + + Current_Loop : Iir := Null_Iir; + + procedure Translate_For_Loop_Statement_State + (Stmt : Iir_For_Loop_Statement) + is + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + It_Info : constant Ortho_Info_Acc := Get_Info (Iterator); + Info : constant Loop_State_Info_Acc := Get_Info (Stmt); + Loop_If : O_If_Block; + Cond : O_Enode; + begin + pragma Assert (It_Info /= null); - Finish_Loop_Stmt (Data.Label_Exit); - Finish_If_Stmt (Data.If_Blk); + Info.Loop_State_Next := State_Allocate; + Info.Loop_State_Exit := State_Allocate; + Info.Loop_State_Body := State_Allocate; + + -- Loop header: initialize iterator, skip the whole body in case of + -- null range. + Open_Temp; + Start_For_Loop (Iterator, Cond); + Start_If_Stmt (Loop_If, Cond); + State_Jump (Info.Loop_State_Body); + New_Else_Stmt (Loop_If); + State_Jump (Info.Loop_State_Exit); + Finish_If_Stmt (Loop_If); Close_Temp; - if Data.Stmt /= Null_Iir then - Free_Info (Data.Stmt); - end if; - end Finish_For_Loop; + -- Loop body. + State_Start (Info.Loop_State_Body); + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + State_Jump (Info.Loop_State_Next); - Current_Loop : Iir := Null_Iir; + -- Loop next. + State_Start (Info.Loop_State_Next); + Exit_Cond_For_Loop (Iterator, Cond); + Start_If_Stmt (Loop_If, Cond); + State_Jump (Info.Loop_State_Exit); + New_Else_Stmt (Loop_If); + Update_For_Loop (Iterator); + State_Jump (Info.Loop_State_Body); + Finish_If_Stmt (Loop_If); - procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + -- Exit state, after loop. + State_Start (Info.Loop_State_Exit); + + Free_Info (Iterator); + end Translate_For_Loop_Statement_State; + + procedure Translate_For_Loop_Statement_Direct + (Stmt : Iir_For_Loop_Statement) is - Iterator : constant Iir := Get_Parameter_Specification (Stmt); - Iter_Type : constant Iir := Get_Type (Iterator); - Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); - Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); - Data : For_Loop_Data; - It_Info : Ortho_Info_Acc; - Var_Iter : Var_Type; - Prev_Loop : Iir; + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Loop_Info : Loop_Info_Acc; + + -- If around the loop, to check if the loop must be executed. + Loop_If : O_If_Block; + Cond : O_Enode; begin - Prev_Loop := Current_Loop; - Current_Loop := Stmt; Start_Declare_Stmt; - Chap3.Translate_Object_Subtype (Iterator, False); + Open_Temp; - -- Create info for the iterator. - It_Info := Add_Info (Iterator, Kind_Iterator); - Var_Iter := Create_Var - (Create_Var_Identifier (Iterator), - Iter_Type_Info.Ortho_Type (Mode_Value), - O_Storage_Local); - It_Info.Iterator_Var := Var_Iter; + Translate_For_Loop_Statement_Declaration (Stmt); + + -- Loop header: initialize iterator. + Start_For_Loop (Iterator, Cond); - Start_For_Loop (Iterator, Stmt, Data); + -- Skip the whole loop in case of null range. + Start_If_Stmt (Loop_If, Cond); + -- Start loop. + -- There are two blocks: one for the exit, one for the next. + + Loop_Info := Add_Info (Stmt, Kind_Loop); + Start_Loop_Stmt (Loop_Info.Label_Exit); + Start_Loop_Stmt (Loop_Info.Label_Next); + + -- Loop body. Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); - Finish_For_Loop (Data); + -- Fake 'next' statement. + New_Exit_Stmt (Loop_Info.Label_Next); + Finish_Loop_Stmt (Loop_Info.Label_Next); + + -- Exit loop if right bound reached. + Exit_Cond_For_Loop (Iterator, Cond); + Gen_Exit_When (Loop_Info.Label_Exit, Cond); + + Update_For_Loop (Iterator); + + Finish_Loop_Stmt (Loop_Info.Label_Exit); + Finish_If_Stmt (Loop_If); + Close_Temp; + + Free_Info (Stmt); Finish_Declare_Stmt; Free_Info (Iterator); + end Translate_For_Loop_Statement_Direct; + + procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + is + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + + if Get_Suspend_Flag (Stmt) then + Translate_For_Loop_Statement_State (Stmt); + else + Translate_For_Loop_Statement_Direct (Stmt); + end if; + Current_Loop := Prev_Loop; end Translate_For_Loop_Statement; - procedure Translate_While_Loop_Statement - (Stmt : Iir_While_Loop_Statement) + procedure Translate_While_Loop_Statement (Stmt : Iir_While_Loop_Statement) is - Info : Loop_Info_Acc; - Cond : Iir; + Cond : constant Iir := Get_Condition (Stmt); Prev_Loop : Iir; begin Prev_Loop := Current_Loop; Current_Loop := Stmt; - Info := Add_Info (Stmt, Kind_Loop); + if Get_Suspend_Flag (Stmt) then + declare + Info : constant Loop_State_Info_Acc := Get_Info (Stmt); + Blk : O_If_Block; + begin + Info.Loop_State_Next := State_Allocate; + Info.Loop_State_Exit := State_Allocate; - Start_Loop_Stmt (Info.Label_Exit); - Info.Label_Next := O_Snode_Null; + -- NEXT_STATE: + State_Jump (Info.Loop_State_Next); + State_Start (Info.Loop_State_Next); - Open_Temp; - Cond := Get_Condition (Stmt); - if Cond /= Null_Iir then - Gen_Exit_When - (Info.Label_Exit, - New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); - end if; - Close_Temp; + if Cond /= Null_Iir then + Info.Loop_State_Body := State_Allocate; - Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + -- if COND then + -- goto BODY_STATE; + -- else + -- goto EXIT_STATE; + -- end if; + Open_Temp; + Start_If_Stmt (Blk, Chap7.Translate_Expression (Cond)); + State_Jump (Info.Loop_State_Body); + New_Else_Stmt (Blk); + State_Jump (Info.Loop_State_Exit); + Finish_If_Stmt (Blk); + Close_Temp; + + -- BODY_STATE: + State_Start (Info.Loop_State_Body); + end if; + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + -- goto NEXT_STATE + State_Jump (Info.Loop_State_Next); + + -- EXIT_STATE: + State_Start (Info.Loop_State_Exit); + end; + else + declare + Info : Loop_Info_Acc; + begin + Info := Add_Info (Stmt, Kind_Loop); + + Start_Loop_Stmt (Info.Label_Exit); + Info.Label_Next := O_Snode_Null; + + Open_Temp; + if Cond /= Null_Iir then + Gen_Exit_When + (Info.Label_Exit, + New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); + end if; + Close_Temp; + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_Loop_Stmt (Info.Label_Exit); + end; + end if; - Finish_Loop_Stmt (Info.Label_Exit); Free_Info (Stmt); Current_Loop := Prev_Loop; end Translate_While_Loop_Statement; @@ -468,14 +791,10 @@ package body Trans.Chap8 is is Cond : constant Iir := Get_Condition (Stmt); If_Blk : O_If_Block; - Info : Loop_Info_Acc; + Info : Ortho_Info_Acc; Loop_Label : Iir; Loop_Stmt : Iir; begin - if Cond /= Null_Iir then - Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); - end if; - Loop_Label := Get_Loop_Label (Stmt); if Loop_Label = Null_Iir then Loop_Stmt := Current_Loop; @@ -484,22 +803,58 @@ package body Trans.Chap8 is end if; Info := Get_Info (Loop_Stmt); - case Get_Kind (Stmt) is - when Iir_Kind_Exit_Statement => - New_Exit_Stmt (Info.Label_Exit); - when Iir_Kind_Next_Statement => - if Info.Label_Next /= O_Snode_Null then - -- For-loop. - New_Exit_Stmt (Info.Label_Next); - else - -- While-loop. - New_Next_Stmt (Info.Label_Exit); - end if; - when others => - raise Internal_Error; - end case; + + -- Common part. if Cond /= Null_Iir then - Finish_If_Stmt (If_Blk); + Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); + end if; + + if Get_Suspend_Flag (Loop_Stmt) then + -- The corresponding loop is state based. Jump to the right state. + case Get_Kind (Stmt) is + when Iir_Kind_Exit_Statement => + State_Jump (Info.Loop_State_Exit); + when Iir_Kind_Next_Statement => + State_Jump (Info.Loop_State_Next); + when others => + raise Internal_Error; + end case; + + -- Force the jump, so that it would work even if the next/exit is + -- not immediately within a state construct. Example: + -- loop + -- if cond then + -- exit; + -- else + -- i := i + 1; + -- end if; + -- wait for 1 ns; + -- end loop; + -- A new state cannot be created here, as the outer construct is the + -- if statement and not the case statement for the state machine. + State_Jump_Force; + + if Cond /= Null_Iir then + Finish_If_Stmt (If_Blk); + end if; + else + case Get_Kind (Stmt) is + when Iir_Kind_Exit_Statement => + New_Exit_Stmt (Info.Label_Exit); + when Iir_Kind_Next_Statement => + if Info.Label_Next /= O_Snode_Null then + -- For-loop. + New_Exit_Stmt (Info.Label_Next); + else + -- While-loop. + New_Next_Stmt (Info.Label_Exit); + end if; + when others => + raise Internal_Error; + end case; + if Cond /= Null_Iir then + Finish_If_Stmt (If_Blk); + end if; end if; end Translate_Exit_Next_Statement; @@ -737,22 +1092,20 @@ package body Trans.Chap8 is Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Func : Iir) - return O_Enode + return O_Enode is Assoc : O_Assoc_List; Func_Info : Subprg_Info_Acc; begin - New_Assign_Stmt - (New_Selected_Element (New_Obj (Val_Node), - Tinfo.T.Base_Field (Mode_Value)), - Val); + New_Assign_Stmt (New_Selected_Element (New_Obj (Val_Node), + Tinfo.T.Base_Field (Mode_Value)), + Val); Func_Info := Get_Info (Func); Start_Association (Assoc, Func_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); New_Association (Assoc, New_Obj_Value (Expr)); - New_Association - (Assoc, New_Address (New_Obj (Val_Node), - Tinfo.Ortho_Ptr_Type (Mode_Value))); + New_Association (Assoc, New_Address (New_Obj (Val_Node), + Tinfo.Ortho_Ptr_Type (Mode_Value))); return New_Function_Call (Assoc); end Translate_Simple_String_Choice; @@ -764,13 +1117,12 @@ package body Trans.Chap8 is Expr_Node : out O_Dnode; C_Node : out O_Dnode) is - Expr : Iir; + Expr : constant Iir := Get_Expression (Stmt); Base_Type : Iir; begin -- Translate into if/elsif statements. -- FIXME: if the number of literals ** length of the array < 256, -- use a case statement. - Expr := Get_Expression (Stmt); Expr_Type := Get_Type (Expr); Base_Type := Get_Base_Type (Expr_Type); Tinfo := Get_Info (Base_Type); @@ -789,28 +1141,75 @@ package body Trans.Chap8 is (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); end Translate_String_Case_Statement_Common; + -- Translate only the statements in choice. The state after the whole case + -- statement is NEXT_STATE, the state for the choices are NEXT_STATE + 1 .. + -- NEXT_STATE + nbr_choices. + procedure Translate_Case_Statement_State + (Stmt : Iir_Case_Statement; Next_State : State_Type) + is + Choice : Iir; + Choice_State : State_Type; + begin + Choice_State := Next_State; + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + if not Get_Same_Alternative_Flag (Choice) then + Choice_State := Choice_State + 1; + State_Start (Choice_State); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + State_Jump (Next_State); + end if; + Choice := Get_Chain (Choice); + end loop; + State_Start (Next_State); + end Translate_Case_Statement_State; + -- Translate a string case statement using a dichotomy. + -- NBR_CHOICES is the number of non-others choices. procedure Translate_String_Case_Statement_Dichotomy - (Stmt : Iir_Case_Statement) + (Stmt : Iir_Case_Statement; Nbr_Choices : Positive) is + Has_Suspend : constant Boolean := Get_Suspend_Flag (Stmt); + Choices_Chain : constant Iir := + Get_Case_Statement_Alternative_Chain (Stmt); + + type Choice_Id is new Integer; + subtype Valid_Choice_Id is Choice_Id + range 0 .. Choice_Id (Nbr_Choices - 1); + No_Choice_Id : constant Choice_Id := -1; + + type Choice_Info_Type is record + -- List of choices, used to sort them. + Choice_Chain : Choice_Id; + -- Association index. + Choice_Assoc : Natural; + -- Corresponding choice simple expression. + Choice_Expr : Iir; + -- Corresponding choice. + Choice_Parent : Iir; + end record; + + type Choice_Info_Arr is array (Valid_Choice_Id) of Choice_Info_Type; + Choices_Info : Choice_Info_Arr; + First, Last : Choice_Id; + El : Choice_Id; + -- Selector. Expr_Type : Iir; Tinfo : Type_Info_Acc; Expr_Node : O_Dnode; C_Node : O_Dnode; + Var_Idx : O_Dnode; + Others_Lit : O_Cnode; - Choices_Chain : Iir; Choice : Iir; Has_Others : Boolean; Func : Iir; - -- Number of non-others choices. - Nbr_Choices : Natural; -- Number of associations. Nbr_Assocs : Natural; - Info : Ortho_Info_Acc; - First, Last : Ortho_Info_Acc; Sel_Length : Iir_Int64; -- Dichotomy table (table of choices). @@ -829,53 +1228,44 @@ package body Trans.Chap8 is Assoc_Table_Type : O_Tnode; Assoc_Table : O_Dnode; begin - Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - - -- Count number of choices and number of associations. - Nbr_Choices := 0; + -- Fill Choices_Info array, and count number of associations. + Last := No_Choice_Id; Nbr_Assocs := 0; - Choice := Choices_Chain; - First := null; - Last := null; Has_Others := False; + Choice := Choices_Chain; while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - Has_Others := True; - exit; - when Iir_Kind_Choice_By_Expression => - null; - when others => - raise Internal_Error; - end case; + if Get_Kind (Choice) = Iir_Kind_Choice_By_Others then + Has_Others := True; + exit; + end if; + pragma Assert (Get_Kind (Choice) = Iir_Kind_Choice_By_Expression); if not Get_Same_Alternative_Flag (Choice) then Nbr_Assocs := Nbr_Assocs + 1; end if; - Info := Add_Info (Choice, Kind_Str_Choice); - if First = null then - First := Info; - else - Last.Choice_Chain := Info; - end if; - Last := Info; - Info.Choice_Chain := null; - Info.Choice_Assoc := Nbr_Assocs - 1; - Info.Choice_Parent := Choice; - Info.Choice_Expr := Get_Choice_Expression (Choice); - - Nbr_Choices := Nbr_Choices + 1; + Last := Last + 1; + Choices_Info (Last) := + (Choice_Chain => Last + 1, + Choice_Assoc => Nbr_Assocs - 1, + Choice_Parent => Choice, + Choice_Expr => Get_Choice_Expression (Choice)); Choice := Get_Chain (Choice); end loop; + -- There is at most one choice (otherwise the linear algorithm must + -- have been used). + pragma Assert (Last /= No_Choice_Id); + First := 0; + Choices_Info (Last).Choice_Chain := No_Choice_Id; + -- Sort choices. declare - procedure Merge_Sort (Head : Ortho_Info_Acc; + procedure Merge_Sort (Head : Choice_Id; Nbr : Natural; - Res : out Ortho_Info_Acc; - Next : out Ortho_Info_Acc) + Res : out Choice_Id; + Next : out Choice_Id) is - L, R, L_End, R_End : Ortho_Info_Acc; - E, Last : Ortho_Info_Acc; + L, R, L_End, R_End : Choice_Id; + E, Last : Choice_Id; Half : constant Natural := Nbr / 2; begin -- Sorting less than 2 elements is easy! @@ -884,54 +1274,57 @@ package body Trans.Chap8 is if Nbr = 0 then Next := Head; else - Next := Head.Choice_Chain; + Next := Choices_Info (Head).Choice_Chain; end if; return; end if; + -- Split in two and sort. Merge_Sort (Head, Half, L, L_End); Merge_Sort (L_End, Nbr - Half, R, R_End); Next := R_End; -- Merge - Last := null; + Last := No_Choice_Id; loop if L /= L_End and then (R = R_End or else - Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) - = Compare_Lt) + Compare_String_Literals (Choices_Info (L).Choice_Expr, + Choices_Info (R).Choice_Expr) + = Compare_Lt) then + -- Pick L. E := L; - L := L.Choice_Chain; + L := Choices_Info (L).Choice_Chain; elsif R /= R_End then + -- Pick R. E := R; - R := R.Choice_Chain; + R := Choices_Info (R).Choice_Chain; else exit; end if; - if Last = null then + -- Append. + if Last = No_Choice_Id then Res := E; else - Last.Choice_Chain := E; + Choices_Info (Last).Choice_Chain := E; end if; Last := E; end loop; - Last.Choice_Chain := R_End; + Choices_Info (Last).Choice_Chain := R_End; end Merge_Sort; - Next : Ortho_Info_Acc; begin - Merge_Sort (First, Nbr_Choices, First, Next); - if Next /= null then - raise Internal_Error; - end if; + Merge_Sort (First, Nbr_Choices, First, Last); + pragma Assert (Last = No_Choice_Id); end; + Open_Temp; Translate_String_Case_Statement_Common (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); - -- Generate choices table. + -- Generate the sorted array of choices. Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Expr_Type)); String_Type := New_Constrained_Array_Type @@ -947,16 +1340,17 @@ package body Trans.Chap8 is Table_Type); Start_Const_Value (Table); Start_Array_Aggr (List, Table_Type); - Info := First; - while Info /= null loop + + El := First; + while El /= No_Choice_Id loop New_Array_Aggr_El (List, Chap7.Translate_Static_Expression - (Info.Choice_Expr, Expr_Type)); - Info := Info.Choice_Chain; + (Choices_Info (El).Choice_Expr, Expr_Type)); + El := Choices_Info (El).Choice_Chain; end loop; Finish_Array_Aggr (List, Table_Cst); Finish_Const_Value (Table, Table_Cst); - -- Generate assoc table. + -- Generate table from choice to statements block. Assoc_Table_Base_Type := New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); @@ -968,12 +1362,13 @@ package body Trans.Chap8 is O_Storage_Private, Assoc_Table_Type); Start_Const_Value (Assoc_Table); Start_Array_Aggr (List, Assoc_Table_Type); - Info := First; - while Info /= null loop + El := First; + while El /= No_Choice_Id loop New_Array_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Info.Choice_Assoc))); - Info := Info.Choice_Chain; + (List, New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Choices_Info (El).Choice_Assoc))); + El := Choices_Info (El).Choice_Chain; end loop; Finish_Array_Aggr (List, Table_Cst); Finish_Const_Value (Assoc_Table, Table_Cst); @@ -982,14 +1377,12 @@ package body Trans.Chap8 is declare Var_Lo, Var_Hi, Var_Mid : O_Dnode; Var_Cmp : O_Dnode; - Var_Idx : O_Dnode; Label : O_Snode; - Others_Lit : O_Cnode; If_Blk1, If_Blk2 : O_If_Block; - Case_Blk : O_Case_Block; begin Var_Idx := Create_Temp (Ghdl_Index_Type); + -- Declare Lo, Hi, Mid, Cmp. Start_Declare_Stmt; New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); @@ -998,6 +1391,9 @@ package body Trans.Chap8 is New_Var_Decl (Var_Cmp, Wki_Cmp, O_Storage_Local, Ghdl_Compare_Type); + -- Generate: + -- Lo := 0; + -- Hi := Nbr_Choices - 1; New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); New_Assign_Stmt (New_Obj (Var_Hi), @@ -1012,48 +1408,75 @@ package body Trans.Chap8 is (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); end if; + -- Generate: + -- loop + -- Mid := (Lo + Hi) / 2; + -- Cmp := COMPARE (Expr, Table[Mid]); Start_Loop_Stmt (Label); New_Assign_Stmt (New_Obj (Var_Mid), New_Dyadic_Op (ON_Div_Ov, - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Lo), - New_Obj_Value (Var_Hi)), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, 2)))); + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Lo), + New_Obj_Value (Var_Hi)), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 2)))); New_Assign_Stmt (New_Obj (Var_Cmp), Translate_Simple_String_Choice (Expr_Node, New_Address (New_Indexed_Element (New_Obj (Table), - New_Obj_Value (Var_Mid)), - Tinfo.T.Base_Ptr_Type (Mode_Value)), + New_Obj_Value (Var_Mid)), + Tinfo.T.Base_Ptr_Type (Mode_Value)), C_Node, Tinfo, Func)); + + -- Generate: + -- if Cmp = Eq then + -- Idx := Mid; + -- exit; + -- end if; Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Cmp), - New_Lit (Ghdl_Compare_Eq), - Ghdl_Bool_Type)); + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Eq), + Ghdl_Bool_Type)); New_Assign_Stmt (New_Obj (Var_Idx), New_Value (New_Indexed_Element (New_Obj (Assoc_Table), - New_Obj_Value (Var_Mid)))); + New_Obj_Value (Var_Mid)))); New_Exit_Stmt (Label); Finish_If_Stmt (If_Blk1); + -- Generate: + -- if Cmp = Lt then + -- if Mid < Lo then + -- Idx := others; + -- exit; + -- else + -- Hi := Mid - 1; + -- end if; + -- else + -- if Mid > Hi then + -- Idx := others; + -- exit; + -- else + -- Lo := Mid + 1; + -- end if; + -- end if; + -- end loop; Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Cmp), - New_Lit (Ghdl_Compare_Lt), - Ghdl_Bool_Type)); + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Lt), + Ghdl_Bool_Type)); Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Le, - New_Obj_Value (Var_Mid), - New_Obj_Value (Var_Lo), - Ghdl_Bool_Type)); + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Lo), + Ghdl_Bool_Type)); if not Has_Others then Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); else @@ -1063,8 +1486,8 @@ package body Trans.Chap8 is New_Else_Stmt (If_Blk2); New_Assign_Stmt (New_Obj (Var_Hi), New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Var_Mid), - New_Lit (Ghdl_Index_1))); + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); Finish_If_Stmt (If_Blk2); New_Else_Stmt (If_Blk1); @@ -1072,9 +1495,9 @@ package body Trans.Chap8 is Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_Mid), - New_Obj_Value (Var_Hi), - Ghdl_Bool_Type)); + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Hi), + Ghdl_Bool_Type)); if not Has_Others then Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); else @@ -1084,8 +1507,8 @@ package body Trans.Chap8 is New_Else_Stmt (If_Blk2); New_Assign_Stmt (New_Obj (Var_Lo), New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Mid), - New_Lit (Ghdl_Index_1))); + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); Finish_If_Stmt (If_Blk2); Finish_If_Stmt (If_Blk1); @@ -1093,9 +1516,27 @@ package body Trans.Chap8 is Finish_Loop_Stmt (Label); Finish_Declare_Stmt; + end; + + -- Generate: + -- case Idx is + -- when ch1 + -- | ch2 => stmt_list1; + -- when ch3 => stmt_list2; + -- ... + -- end case; + declare + Case_Blk : O_Case_Block; + Next_State : State_Type; + Choice_State : State_Type; + begin + if Has_Suspend then + Next_State := State_Allocate; + end if; Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); + Nbr_Assocs := 0; Choice := Choices_Chain; while Choice /= Null_Iir loop case Get_Kind (Choice) is @@ -1103,21 +1544,32 @@ package body Trans.Chap8 is Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, Others_Lit); Finish_Choice (Case_Blk); - Translate_Statements_Chain - (Get_Associated_Chain (Choice)); + if Has_Suspend then + Choice_State := State_Allocate; + State_Jump (Choice_State); + else + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + end if; when Iir_Kind_Choice_By_Expression => if not Get_Same_Alternative_Flag (Choice) then Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Get_Info (Choice).Choice_Assoc))); + (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs))); Finish_Choice (Case_Blk); - Translate_Statements_Chain - (Get_Associated_Chain (Choice)); + if Has_Suspend then + Choice_State := State_Allocate; + State_Jump (Choice_State); + else + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + end if; + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; + end if; end if; - Free_Info (Choice); when others => raise Internal_Error; end case; @@ -1130,6 +1582,11 @@ package body Trans.Chap8 is Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); Finish_Case_Stmt (Case_Blk); + Close_Temp; + + if Has_Suspend then + Translate_Case_Statement_State (Stmt, Next_State); + end if; end; end Translate_String_Case_Statement_Dichotomy; @@ -1138,6 +1595,10 @@ package body Trans.Chap8 is procedure Translate_String_Case_Statement_Linear (Stmt : Iir_Case_Statement) is + Has_Suspend : constant Boolean := Get_Suspend_Flag (Stmt); + Next_State : State_Type; + Choice_State : State_Type; + Expr_Type : Iir; -- Node containing the address of the selector. Expr_Node : O_Dnode; @@ -1172,10 +1633,15 @@ package body Trans.Chap8 is Cond := Translate_Simple_String_Choice (Expr_Node, Chap7.Translate_Expression (Ch_Expr, - Get_Type (Ch_Expr)), + Get_Type (Ch_Expr)), Val_Node, Tinfo, Func); when Iir_Kind_Choice_By_Others => - Translate_Statements_Chain (Stmt_Chain); + if Has_Suspend then + Choice_State := State_Allocate; + State_Jump (Choice_State); + else + Translate_Statements_Chain (Stmt_Chain); + end if; return; when others => Error_Kind ("translate_string_choice", Ch); @@ -1198,12 +1664,18 @@ package body Trans.Chap8 is Cond := New_Obj_Value (Cond_Var); end if; Start_If_Stmt (If_Blk, Cond); - Translate_Statements_Chain (Stmt_Chain); + if Has_Suspend then + Choice_State := State_Allocate; + State_Jump (Choice_State); + else + Translate_Statements_Chain (Stmt_Chain); + end if; New_Else_Stmt (If_Blk); Translate_String_Choice (Ch); Finish_If_Stmt (If_Blk); end Translate_String_Choice; begin + Open_Temp; Translate_String_Case_Statement_Common (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); @@ -1212,7 +1684,16 @@ package body Trans.Chap8 is Cond_Var := Create_Temp (Std_Boolean_Type_Node); + if Has_Suspend then + Next_State := State_Allocate; + end if; + Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); + Close_Temp; + + if Has_Suspend then + Translate_Case_Statement_State (Stmt, Next_State); + end if; end Translate_String_Case_Statement_Linear; procedure Translate_Case_Choice @@ -1245,19 +1726,16 @@ package body Trans.Chap8 is procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) is - Expr : Iir; - Expr_Type : Iir; - Case_Blk : O_Case_Block; - Choice : Iir; - Stmt_Chain : Iir; + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); begin - Expr := Get_Expression (Stmt); - Expr_Type := Get_Type (Expr); if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then + -- Expression is a one-dimensional array. declare Nbr_Choices : Natural := 0; Choice : Iir; begin + -- Count number of choices. Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop case Get_Kind (Choice) is @@ -1272,30 +1750,53 @@ package body Trans.Chap8 is Choice := Get_Chain (Choice); end loop; + -- Select the strategy according to the number of choices. if Nbr_Choices < 3 then Translate_String_Case_Statement_Linear (Stmt); else - Translate_String_Case_Statement_Dichotomy (Stmt); + Translate_String_Case_Statement_Dichotomy (Stmt, Nbr_Choices); + end if; + end; + else + -- Normal case statement: expression is discrete. + declare + Has_Suspend : constant Boolean := Get_Suspend_Flag (Stmt); + Case_Blk : O_Case_Block; + Choice : Iir; + Stmt_Chain : Iir; + Next_State : State_Type; + Choice_State : State_Type; + begin + Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + if Has_Suspend then + Next_State := State_Allocate; + end if; + while Choice /= Null_Iir loop + Start_Choice (Case_Blk); + Stmt_Chain := Get_Associated_Chain (Choice); + loop + Translate_Case_Choice (Choice, Expr_Type, Case_Blk); + Choice := Get_Chain (Choice); + exit when Choice = Null_Iir; + exit when not Get_Same_Alternative_Flag (Choice); + pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); + end loop; + Finish_Choice (Case_Blk); + if Has_Suspend then + Choice_State := State_Allocate; + State_Jump (Choice_State); + else + Translate_Statements_Chain (Stmt_Chain); + end if; + end loop; + Finish_Case_Stmt (Case_Blk); + + if Has_Suspend then + Translate_Case_Statement_State (Stmt, Next_State); end if; end; - return; end if; - Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); - Choice := Get_Case_Statement_Alternative_Chain (Stmt); - while Choice /= Null_Iir loop - Start_Choice (Case_Blk); - Stmt_Chain := Get_Associated_Chain (Choice); - loop - Translate_Case_Choice (Choice, Expr_Type, Case_Blk); - Choice := Get_Chain (Choice); - exit when Choice = Null_Iir; - exit when not Get_Same_Alternative_Flag (Choice); - pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); - end loop; - Finish_Choice (Case_Blk); - Translate_Statements_Chain (Stmt_Chain); - end loop; - Finish_Case_Stmt (Case_Blk); end Translate_Case_Statement; procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) @@ -1531,7 +2032,7 @@ package body Trans.Chap8 is New_Association (Constr, Chap7.Translate_Expression (Name_Param, - String_Type_Definition)); + String_Type_Definition)); New_Procedure_Call (Constr); end; @@ -1609,6 +2110,268 @@ package body Trans.Chap8 is end case; end Translate_Implicit_Procedure_Call; + function Get_Interface_Kind (Formal : Iir) return Object_Kind_Type is + begin + if Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration then + return Mode_Signal; + else + return Mode_Value; + end if; + end Get_Interface_Kind; + + procedure Translate_Procedure_Call_State (Call : Iir) + is + Imp : constant Iir := Get_Implementation (Call); + Info : constant Call_Info_Acc := Get_Info (Call); + + Assoc : Iir; + Num : Natural; + begin + Push_Instance_Factory (Info.Call_State_Scope'Access); + + -- Variable for the frame. + Info.Call_Frame_Var := Create_Var (Create_Var_Identifier ("FRAME"), + Get_Info (Imp).Subprg_Params_Type, + O_Storage_Local); + Info.Call_State_Mark := Create_Var (Create_Var_Identifier ("MARK"), + Ghdl_Ptr_Type, O_Storage_Local); + + Assoc := Get_Parameter_Association_Chain (Call); + Num := 0; + while Assoc /= Null_Iir loop + declare + Formal : constant Iir := Strip_Denoting_Name (Get_Formal (Assoc)); + Ftype : constant Iir := Get_Type (Formal); + Ftype_Info : constant Type_Info_Acc := Get_Info (Ftype); + Inter : constant Iir := Get_Association_Interface (Assoc); + Call_Assoc_Info : Call_Assoc_Info_Acc; + Actual : Iir; + Act_Type : Iir; + Atype_Info : Type_Info_Acc; + Has_Bounds_Field : Boolean; + Has_Fat_Pointer_Field : Boolean; + Has_Value_Field : Boolean; + Has_Ref_Field : Boolean; + Object_Kind : Object_Kind_Type; + Val_Type : O_Tnode; + + -- For unconstrained interfaces: + -- * create a field for the fat pointer, unless + -- - the expression is locally static + function Need_Fat_Pointer_Field return Boolean is + begin + return not Is_Fully_Constrained_Type (Ftype) + and then (Actual = Null_Iir + or else Get_Expr_Staticness (Actual) /= Locally); + end Need_Fat_Pointer_Field; + + -- For unconstrained interfaces: + -- * create a field for the bounds, unless + -- - the expression is locally static + -- - the expression/name type is locally static + -- - expression is a call to an unconstrained function + -- - expression is an object name that is not a slice + function Need_Bounds_Field return Boolean + is + Kind : Iir_Kind; + begin + if Is_Fully_Constrained_Type (Ftype) then + return False; + end if; + if Act_Type /= Null_Iir + and then Get_Type_Staticness (Act_Type) = Locally + then + return False; + end if; + if Actual /= Null_Iir then + if Get_Expr_Staticness (Actual) = Locally then + return False; + end if; + Kind := Get_Kind (Actual); + if (Kind = Iir_Kind_Function_Call + or else Kind in Iir_Kinds_Dyadic_Operator + or else Kind in Iir_Kinds_Monadic_Operator) + and then Is_Fully_Constrained_Type (Get_Type (Actual)) + then + return False; + end if; + if Is_Object_Name (Actual) + and then Kind /= Iir_Kind_Slice_Name + then + return False; + end if; + end if; + return True; + end Need_Bounds_Field; + + -- Helper for Need_Value_Field. Any expression whose result is + -- on stack2 doesn't need to be copied (again) on stack2. This is + -- an optimization and the result can be conservative. + -- FIXME: also consider attributes (like 'image) and implicit + -- functions (like to_string). + function Is_Result_On_Stack2_Expression (Expr : Iir) return Boolean + is + Info : Ortho_Info_Acc; + Imp : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Function_Call => + Imp := Get_Implementation (Expr); + Info := Get_Info (Imp); + -- Note: Implicit functions don't have info. A few of + -- them (like to_string) return the result on stack2. + return Info /= null + and then Info.Use_Stack2; + when Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator => + return False; + when others => + return False; + end case; + end Is_Result_On_Stack2_Expression; + + -- If the associated expression is not a name of an object (never + -- the case for a signal interface and variable interface): + -- * create a field for the value, unless + -- - expression is locally static + -- - expression is scalar + -- - expression is a call to an unconstrained function + -- If the actual is a name of an object, create a field for the + -- value only if the object is a signal and the interface is + -- a constant (we need to capture the value of the signal). + function Need_Value_Field return Boolean + is + pragma Assert (Actual /= Null_Iir); + Act_Obj : constant Iir := Name_To_Object (Actual); + begin + if Act_Obj /= Null_Iir then + -- Actual is an object. + if (Get_Kind (Formal) + = Iir_Kind_Interface_Constant_Declaration) + and then Is_Signal_Object (Act_Obj) + then + -- The value of the signal needs to be captured. + return True; + end if; + return False; + end if; + + if Get_Expr_Staticness (Actual) = Locally + or else (Get_Kind (Act_Type) + in Iir_Kinds_Scalar_Type_Definition) + or else Get_Kind (Ftype) = Iir_Kind_File_Type_Definition + or else Is_Result_On_Stack2_Expression (Actual) + then + return False; + end if; + return True; + end Need_Value_Field; + begin + Call_Assoc_Info := null; + Has_Bounds_Field := False; + Has_Fat_Pointer_Field := False; + Has_Value_Field := False; + Has_Ref_Field := False; + + case Iir_Kinds_Association_Element (Get_Kind (Assoc)) is + when Iir_Kind_Association_Element_By_Individual => + -- Create a field for the whole formal. + Has_Value_Field := True; + Actual := Null_Iir; + Act_Type := Get_Actual_Type (Assoc); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + Act_Type := Get_Type (Actual); + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Inter); + Act_Type := Get_Type (Actual); + end case; + + -- For out or inout scalar variable, create a field for the + -- value. + if Actual /= Null_Iir + and then (Get_Kind (Inter) + = Iir_Kind_Interface_Variable_Declaration) + and then Get_Mode (Inter) /= Iir_In_Mode + and then + (Formal /= Inter + or else Ftype_Info.Type_Mode in Type_Mode_Call_By_Value) + then + Has_Ref_Field := True; + end if; + + if Formal = Inter + and then Ftype_Info.Type_Mode not in Type_Mode_Thin + then + -- For whole association: create field according to the above + -- predicates. + -- For thin modes, there is no bounds, no fat pointers and the + -- value is directly passed in the parameters. + Has_Bounds_Field := Need_Bounds_Field; + Has_Fat_Pointer_Field := Need_Fat_Pointer_Field; + Has_Value_Field := Has_Value_Field or else Need_Value_Field; + end if; + + if Has_Bounds_Field + or Has_Fat_Pointer_Field + or Has_Value_Field + or Has_Ref_Field + then + -- Create the info and the variables. + Call_Assoc_Info := Add_Info (Assoc, Kind_Call_Assoc); + Object_Kind := Get_Interface_Kind (Inter); + if Has_Ref_Field then + -- Reference to the actual. Therefore the type of the + -- actual must be used (due to a possible conversion or + -- function call). + Atype_Info := Get_Info (Act_Type); + Call_Assoc_Info.Call_Assoc_Ref := Create_Var + (Create_Var_Identifier (Inter, "__REF", Num), + Atype_Info.Ortho_Ptr_Type (Object_Kind), + O_Storage_Local); + end if; + if Has_Value_Field then + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + -- For unconstrained arrays/records: + -- - the array (if the actual is constrained and not + -- complex) - TODO + -- - a pointer to the base. + Val_Type := Ftype_Info.T.Base_Ptr_Type (Object_Kind); + else + -- For constrained arrays/records: + -- - the base if not complex + -- - a pointer to the base, if complex + if Is_Complex_Type (Ftype_Info) then + Val_Type := Ftype_Info.Ortho_Ptr_Type (Object_Kind); + else + Val_Type := Ftype_Info.Ortho_Type (Object_Kind); + end if; + end if; + Call_Assoc_Info.Call_Assoc_Value := Create_Var + (Create_Var_Identifier (Inter, "__VAL", Num), + Val_Type, O_Storage_Local); + end if; + if Has_Bounds_Field then + Call_Assoc_Info.Call_Assoc_Bounds := Create_Var + (Create_Var_Identifier (Inter, "__BND", Num), + Ftype_Info.T.Bounds_Type, O_Storage_Local); + end if; + if Has_Fat_Pointer_Field then + Call_Assoc_Info.Call_Assoc_Fat := Create_Var + (Create_Var_Identifier (Inter, "__FAT", Num), + Ftype_Info.Ortho_Type (Object_Kind)); + end if; + Num := Num + 1; + end if; + end; + Assoc := Get_Chain (Assoc); + end loop; + + Pop_Instance_Factory (Info.Call_State_Scope'Access); + New_Type_Decl (Create_Identifier ("CALLERTYPE"), + Get_Scope_Type (Info.Call_State_Scope)); + end Translate_Procedure_Call_State; + function Do_Conversion (Conv : Iir; Expr : Iir; Src : O_Enode) return O_Enode is begin @@ -1699,15 +2462,27 @@ package body Trans.Chap8 is return Res; end Translate_Individual_Association_Formal; - function Translate_Subprogram_Call (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) - return O_Enode + function Translate_Subprogram_Call + (Call : Iir; Assoc_Chain : Iir; Obj : Iir) return O_Enode is + Imp : constant Iir := Get_Implementation (Call); + Is_Procedure : constant Boolean := Get_Kind (Imp) = Iir_Kind_Procedure_Declaration; Is_Function : constant Boolean := not Is_Procedure; Is_Foreign : constant Boolean := Get_Foreign_Flag (Imp); Info : constant Subprg_Info_Acc := Get_Info (Imp); + -- True if the callee is suspendable. + Does_Callee_Suspend : constant Boolean := Is_Procedure + and then Get_Suspend_Flag (Imp); + + Call_Info : constant Ortho_Info_Acc := Get_Info (Call); + + -- True if the caller is suspendable. The callee can still be + -- suspendable, but cannot suspend. + Is_Suspendable : constant Boolean := Call_Info /= null; + type Mnode_Array is array (Natural range <>) of Mnode; type O_Enode_Array is array (Natural range <>) of O_Enode; Nbr_Assoc : constant Natural := @@ -1724,29 +2499,17 @@ package body Trans.Chap8 is -- the copy of the scalar. Inout_Params : Mnode_Array (0 .. Nbr_Assoc - 1); - Params_Var : O_Dnode; + Params_Var : Var_Type; Res : Mnode; El : Iir; Pos : Natural; Constr : O_Assoc_List; - Act : Iir; - Actual_Type : Iir; - Formal : Iir; - Mode : Iir_Mode; - Base_Formal : Iir; - Formal_Type : Iir; - Ftype_Info : Type_Info_Acc; - Formal_Info : Ortho_Info_Acc; - Val : O_Enode; - Param : Mnode; - Param_Type : Iir; Last_Individual : Natural; - Ptr : O_Lnode; - In_Conv : Iir; - Out_Conv : Iir; - Out_Expr : Iir; - Formal_Object_Kind : Object_Kind_Type; - Bounds : Mnode; + Mark_Var : Var_Type; + + Call_State : State_Type; + Next_State : State_Type; + If_Blk : O_If_Block; begin -- For functions returning an unconstrained object: save the mark. if Is_Function and then Info.Use_Stack2 then @@ -1767,11 +2530,33 @@ package body Trans.Chap8 is end; end if; - -- Create the variable containing the parameters (only for procedures). - if Is_Procedure and then Info.Subprg_Params_Type /= O_Tnode_Null then - Params_Var := Create_Temp (Info.Subprg_Params_Type); + if Is_Function or else Info.Subprg_Params_Type = O_Tnode_Null then + -- Standard call, like a C function (no parameters struct). + pragma Assert (not Does_Callee_Suspend); + Params_Var := Null_Var; + Mark_Var := Null_Var; else - Params_Var := O_Dnode_Null; + -- Create the variable containing the parameters. + -- Save Stack2 mark. Callee allocate its frame on stack2. + if Is_Suspendable then + -- The caller is suspendable. + Params_Var := Call_Info.Call_Frame_Var; + Mark_Var := Call_Info.Call_State_Mark; + -- There might be temporary variables created before the + -- suspension, eg for range checks. + -- Create a scope that will be closed just before the suspension. + Open_Temp; + Disable_Stack2_Release; + else + -- Caller does not suspend; create the frame variable. + Start_Declare_Stmt; + Mark_Var := Create_Var (Create_Var_Identifier ("CMARK"), + Ghdl_Ptr_Type, O_Storage_Local); + Params_Var := Create_Var (Create_Var_Identifier ("CPARAMS"), + Info.Subprg_Params_Type, + O_Storage_Local); + end if; + Set_Stack2_Mark (Get_Var (Mark_Var)); end if; -- Evaluate in-out parameters and parameters passed by ref, since @@ -1785,156 +2570,304 @@ package body Trans.Chap8 is E_Params (Pos) := O_Enode_Null; Inout_Params (Pos) := Mnode_Null; - Formal := Strip_Denoting_Name (Get_Formal (El)); - Base_Formal := Get_Association_Interface (El); - Formal_Type := Get_Type (Formal); - Formal_Info := Get_Info (Base_Formal); - Ftype_Info := Get_Info (Formal_Type); - - if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration - then - Formal_Object_Kind := Mode_Signal; - else - Formal_Object_Kind := Mode_Value; - end if; - - case Get_Kind (El) is - when Iir_Kind_Association_Element_Open => - Act := Get_Default_Value (Formal); - In_Conv := Null_Iir; - when Iir_Kind_Association_Element_By_Expression => - Act := Get_Actual (El); - In_Conv := Get_In_Conversion (El); - when Iir_Kind_Association_Element_By_Individual => - Actual_Type := Get_Actual_Type (El); - - if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then - -- Create the constraints and then the object. - Chap3.Create_Array_Subtype (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); - Param := Create_Temp (Ftype_Info, Formal_Object_Kind); - Chap3.Translate_Object_Allocation - (Param, Alloc_Stack, Formal_Type, Bounds); - else - -- Create the object. - Param := Create_Temp (Ftype_Info, Formal_Object_Kind); - Chap4.Allocate_Complex_Object - (Formal_Type, Alloc_Stack, Param); - end if; + declare + Assoc_Info : Call_Assoc_Info_Acc; + Base_Formal : constant Iir := Get_Association_Interface (El); + Formal : constant Iir := Strip_Denoting_Name (Get_Formal (El)); + Formal_Type : constant Iir := Get_Type (Formal); + Ftype_Info : constant Type_Info_Acc := Get_Info (Formal_Type); + Formal_Info : constant Ortho_Info_Acc := Get_Info (Base_Formal); + Formal_Object_Kind : constant Object_Kind_Type := + Get_Interface_Kind (Base_Formal); + Act : Iir; + Actual_Type : Iir; + In_Conv : Iir; + Param : Mnode; + Param_Type : Iir; + Val : O_Enode; + Mval : Mnode; + Mode : Iir_Mode; + Ptr : O_Lnode; + Bounds : Mnode; + begin + -- To translate user redefined operators, + -- translate_operator_function_call creates associations, that + -- have not corresponding infos. Do not try to get assoc info + -- for non-suspendable procedures. + -- FIXME: either transform operator to a function call in canon, + -- or directly translate function call. + if Does_Callee_Suspend then + Assoc_Info := Get_Info (El); + else + Assoc_Info := null; + end if; - -- Save the object as it will be used by the following - -- associations. - Last_Individual := Pos; - Params (Pos) := Param; + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + when Iir_Kind_Association_Element_By_Individual => + Actual_Type := Get_Actual_Type (El); + + if Assoc_Info = null then + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + else + declare + Param_Var : Var_Type; + begin + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + Param_Var := Assoc_Info.Call_Assoc_Fat; + else + Param_Var := Assoc_Info.Call_Assoc_Value; + end if; + Param := Stabilize (Get_Var (Param_Var, Ftype_Info, + Formal_Object_Kind)); + end; + end if; - if Formal_Info.Interface_Field /= O_Fnode_Null then - -- Set the PARAMS field. - Ptr := New_Selected_Element - (New_Obj (Params_Var), Formal_Info.Interface_Field); - New_Assign_Stmt (Ptr, M2E (Param)); - end if; + declare + Alloc : Allocation_Kind; + begin + if Does_Callee_Suspend then + Alloc := Alloc_Return; + else + Alloc := Alloc_Stack; + end if; + + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the constraints and then the object. + -- FIXME: do not allocate bounds. + Chap3.Create_Array_Subtype (Actual_Type); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Chap3.Translate_Object_Allocation + (Param, Alloc, Formal_Type, Bounds); + else + -- Create the object. + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc, Param); + end if; + end; + + -- Save the object as it will be used by the following + -- associations. + Last_Individual := Pos; + Params (Pos) := Param; + + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- Set the PARAMS field. + Ptr := New_Selected_Element + (Get_Var (Params_Var), Formal_Info.Interface_Field); + New_Assign_Stmt (Ptr, M2E (Param)); + end if; - goto Continue; - when others => - Error_Kind ("translate_procedure_call", El); - end case; - Actual_Type := Get_Type (Act); - - -- Evaluate the actual. - Param_Type := Actual_Type; - case Get_Kind (Base_Formal) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - -- No conversion here. - pragma Assert (In_Conv = Null_Iir); - Val := Chap7.Translate_Expression (Act, Formal_Type); - Param_Type := Formal_Type; - when Iir_Kind_Interface_Signal_Declaration => - -- No conversion. - Param := Chap6.Translate_Name (Act); - Val := M2E (Param); - when Iir_Kind_Interface_Variable_Declaration => - Mode := Get_Mode (Base_Formal); - if Mode = Iir_In_Mode then - Val := Chap7.Translate_Expression (Act); - else + goto Continue; + when others => + Error_Kind ("translate_procedure_call", El); + end case; + Actual_Type := Get_Type (Act); + + -- Evaluate the actual. + Param_Type := Actual_Type; + case Get_Kind (Base_Formal) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + -- No conversion here. + pragma Assert (In_Conv = Null_Iir); + Val := Chap7.Translate_Expression (Act, Formal_Type); + Param_Type := Formal_Type; + when Iir_Kind_Interface_Signal_Declaration => + -- No conversion. Param := Chap6.Translate_Name (Act); - if Base_Formal /= Formal - or else Ftype_Info.Type_Mode in Type_Mode_Pass_By_Copy - then - -- For out/inout, we need to keep the reference for the - -- copy-out. - Stabilize (Param); - Params (Pos) := Param; - end if; - if In_Conv = Null_Iir - and then Mode = Iir_Out_Mode - and then Ftype_Info.Type_Mode in Type_Mode_Thin - and then Ftype_Info.Type_Mode /= Type_Mode_File - then - -- Scalar OUT interface. Just give an initial value. - -- FIXME: individual association ?? - Val := Chap4.Get_Scalar_Initial_Value (Formal_Type); - Param_Type := Formal_Type; + Val := M2E (Param); + when Iir_Kind_Interface_Variable_Declaration => + Mode := Get_Mode (Base_Formal); + if Mode = Iir_In_Mode then + Val := Chap7.Translate_Expression (Act); else - Val := M2E (Param); + Param := Chap6.Translate_Name (Act); + if Base_Formal /= Formal + or else Ftype_Info.Type_Mode in Type_Mode_Call_By_Value + then + -- For out/inout, we need to keep the reference + -- for the copy-out. + Stabilize (Param); + Params (Pos) := Param; + + if Assoc_Info /= null then + -- Save reference in local frame. + New_Assign_Stmt + (Get_Var (Assoc_Info.Call_Assoc_Ref), + M2Addr (Param)); + end if; + end if; + if In_Conv = Null_Iir + and then Mode = Iir_Out_Mode + and then Ftype_Info.Type_Mode in Type_Mode_Thin + and then Ftype_Info.Type_Mode /= Type_Mode_File + then + -- Scalar OUT interface. Just give an initial value. + -- FIXME: individual association ?? + Val := Chap4.Get_Scalar_Initial_Value (Formal_Type); + Param_Type := Formal_Type; + else + Val := M2E (Param); + end if; + if Is_Foreign + and then Ftype_Info.Type_Mode in Type_Mode_Pass_By_Copy + then + -- Scalar parameters of foreign procedures (of mode + -- out or inout) are passed by address, create a copy + -- of the value. + Inout_Params (Pos) := + Create_Temp (Ftype_Info, Mode_Value); + end if; end if; - - if Is_Foreign - and then Ftype_Info.Type_Mode in Type_Mode_Pass_By_Copy - then - -- Scalar parameters of foreign procedures (of mode out - -- or inout) are passed by address, create a copy of the - -- value. - Inout_Params (Pos) := - Create_Temp (Ftype_Info, Mode_Value); + if In_Conv /= Null_Iir then + Val := Do_Conversion (In_Conv, Act, Val); + Act := In_Conv; + Param_Type := Get_Type (In_Conv); end if; + when others => + Error_Kind ("translate_procedure_call(2)", Formal); + end case; + + -- Implicit conversion to formal type. + if Param_Type /= Formal_Type then + -- Implicit array conversion or subtype check. + Val := Chap7.Translate_Implicit_Conv + (Val, Param_Type, Formal_Type, Formal_Object_Kind, Act); + end if; + if Get_Kind (Base_Formal) /= Iir_Kind_Interface_Signal_Declaration + then + Val := Chap3.Maybe_Insert_Scalar_Check (Val, Act, Formal_Type); + end if; + + -- Assign actual, if needed. + if Base_Formal /= Formal then + -- Individual association: assign the individual actual to + -- the whole actual. + Param := Translate_Individual_Association_Formal + (Formal, Formal_Info, Params (Last_Individual)); + Chap7.Translate_Assign + (Param, Val, Act, Formal_Type, El); + + elsif Assoc_Info /= null then + -- Only for whole association. + pragma Assert (Base_Formal = Formal); + + Mval := Stabilize + (E2M (Val, Ftype_Info, Formal_Object_Kind), True); + + if Assoc_Info.Call_Assoc_Fat /= Null_Var then + -- Fat pointer. VAL is a pointer to a fat pointer, so copy + -- the fat pointer to the FAT field, and set the PARAM + -- field to FAT field. + declare + Fat : Mnode; + begin + Fat := Stabilize + (Get_Var (Assoc_Info.Call_Assoc_Fat, + Ftype_Info, Formal_Object_Kind)); + Copy_Fat_Pointer (Fat, Mval); + + -- Set PARAM field to the address of the FAT field. + pragma Assert + (Formal_Info.Interface_Field /= O_Fnode_Null); + New_Assign_Stmt + (New_Selected_Element (Get_Var (Params_Var), + Formal_Info.Interface_Field), + M2E (Fat)); + end; end if; - if In_Conv /= Null_Iir then - Val := Do_Conversion (In_Conv, Act, Val); - Act := In_Conv; - Param_Type := Get_Type (In_Conv); + + if Assoc_Info.Call_Assoc_Bounds /= Null_Var then + -- Copy the bounds. + pragma Assert (Assoc_Info.Call_Assoc_Fat /= Null_Var); + Chap3.Copy_Bounds + (New_Address (Get_Var (Assoc_Info.Call_Assoc_Bounds), + Ftype_Info.T.Bounds_Ptr_Type), + M2Addr (Chap3.Get_Array_Bounds (Mval)), + Formal_Type); end if; - when others => - Error_Kind ("translate_procedure_call(2)", Formal); - end case; - -- Implicit conversion to formal type. - if Param_Type /= Formal_Type then - -- Implicit array conversion or subtype check. - Val := Chap7.Translate_Implicit_Conv - (Val, Param_Type, Formal_Type, Formal_Object_Kind, Act); - end if; - if Get_Kind (Base_Formal) /= Iir_Kind_Interface_Signal_Declaration - then - Val := Chap3.Maybe_Insert_Scalar_Check (Val, Act, Formal_Type); - end if; + if Assoc_Info.Call_Assoc_Value /= Null_Var then + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + pragma Assert (Assoc_Info.Call_Assoc_Fat /= Null_Var); + -- Allocate array base + Param := Stabilize + (Get_Var (Assoc_Info.Call_Assoc_Fat, + Ftype_Info, Formal_Object_Kind)); + Chap3.Allocate_Fat_Array_Base + (Alloc_Return, Param, Formal_Type); + -- NOTE: Call_Assoc_Value is not used, the base is + -- directly allocated in the fat pointer. + else + Param := Get_Var (Assoc_Info.Call_Assoc_Value, + Ftype_Info, Formal_Object_Kind); + Stabilize (Param); + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_Return, Param); + New_Assign_Stmt + (New_Selected_Element + (Get_Var (Params_Var), Formal_Info.Interface_Field), + M2Addr (Param)); + end if; + Chap3.Translate_Object_Copy + (Param, M2E (Mval), Formal_Type); + end if; - -- Assign actual, if needed. - if Base_Formal /= Formal then - -- Individual association: assign the individual actual to the - -- whole actual. - Param := Translate_Individual_Association_Formal - (Formal, Formal_Info, Params (Last_Individual)); - Chap7.Translate_Assign - (Param, Val, Act, Formal_Type, El); - elsif Formal_Info.Interface_Field /= O_Fnode_Null then - -- Set the PARAMS field. - Ptr := New_Selected_Element - (New_Obj (Params_Var), Formal_Info.Interface_Field); - New_Assign_Stmt (Ptr, Val); - elsif Inout_Params (Pos) /= Mnode_Null then - Chap3.Translate_Object_Copy (Inout_Params (Pos), Val, Formal_Type); - else - E_Params (Pos) := Val; - end if; + if Assoc_Info.Call_Assoc_Value = Null_Var + and then Assoc_Info.Call_Assoc_Fat = Null_Var + then + -- Set the PARAMS field. + New_Assign_Stmt + (New_Selected_Element + (Get_Var (Params_Var), Formal_Info.Interface_Field), + M2E (Mval)); + end if; + elsif Formal_Info.Interface_Field /= O_Fnode_Null then + -- Set the PARAMS field. + Ptr := New_Selected_Element + (Get_Var (Params_Var), Formal_Info.Interface_Field); + New_Assign_Stmt (Ptr, Val); + elsif Inout_Params (Pos) /= Mnode_Null then + Chap3.Translate_Object_Copy + (Inout_Params (Pos), Val, Formal_Type); + E_Params (Pos) := M2Addr (Inout_Params (Pos)); + else + E_Params (Pos) := Val; + end if; + + << Continue >> null; + end; - << Continue >> null; El := Get_Chain (El); Pos := Pos + 1; end loop; -- Second stage: really perform the call. + if Does_Callee_Suspend then + -- Set initial state. + New_Assign_Stmt + (New_Selected_Element (Get_Var (Params_Var), + Info.Subprg_State_Field), + New_Lit (Ghdl_Index_0)); + end if; + if Is_Suspendable then + -- Close the scope created at the beginning. + Close_Temp; + + Call_State := State_Allocate; + Next_State := State_Allocate; + + -- Call state. + State_Jump (Call_State); + State_Start (Call_State); + end if; + Start_Association (Constr, Info.Ortho_Func); if Is_Function and then Info.Res_Interface /= O_Dnode_Null then @@ -1942,10 +2875,11 @@ package body Trans.Chap8 is New_Association (Constr, M2E (Res)); end if; - if Params_Var /= O_Dnode_Null then + if Params_Var /= Null_Var then -- Parameters record (for procedures). - New_Association (Constr, New_Address (New_Obj (Params_Var), - Info.Subprg_Params_Ptr)); + New_Association + (Constr, New_Address (Get_Var (Params_Var), + Info.Subprg_Params_Ptr)); end if; if Obj /= Null_Iir then @@ -1960,30 +2894,28 @@ package body Trans.Chap8 is El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop - Formal := Strip_Denoting_Name (Get_Formal (El)); - Base_Formal := Get_Association_Interface (El); - Formal_Info := Get_Info (Base_Formal); - - if Formal_Info.Interface_Field = O_Fnode_Null then - -- Not a PARAMS field. - if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then - -- Pass the whole data for an individual association. - New_Association (Constr, M2E (Params (Pos))); - elsif Base_Formal = Formal then - -- Whole association. - if Inout_Params (Pos) /= Mnode_Null then - Val := M2Addr (Inout_Params (Pos)); - else - Val := E_Params (Pos); + declare + Formal : constant Iir := Strip_Denoting_Name (Get_Formal (El)); + Base_Formal : constant Iir := Get_Association_Interface (El); + Formal_Info : constant Ortho_Info_Acc := Get_Info (Base_Formal); + begin + if Formal_Info.Interface_Field = O_Fnode_Null then + -- Not a PARAMS field. + if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual + then + -- Pass the whole data for an individual association. + New_Association (Constr, M2E (Params (Pos))); + elsif Base_Formal = Formal then + -- Whole association. + New_Association (Constr, E_Params (Pos)); end if; - New_Association (Constr, Val); end if; - end if; - if Get_Kind (El) = Iir_Kind_Association_Element_Open then - -- Do not share nodes for default values: clean them. - Chap9.Destroy_Types (Get_Default_Value (Base_Formal)); - end if; + if Get_Kind (El) = Iir_Kind_Association_Element_Open then + -- Do not share nodes for default values: clean them. + Chap9.Destroy_Types (Get_Default_Value (Base_Formal)); + end if; + end; El := Get_Chain (El); Pos := Pos + 1; @@ -2002,65 +2934,144 @@ package body Trans.Chap8 is end if; end if; + if Is_Suspendable then + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Neq, + New_Value (New_Selected_Element + (Get_Var (Params_Var), + Info.Subprg_State_Field)), + New_Lit (Ghdl_Index_1), + Ghdl_Bool_Type)); + State_Suspend (Call_State); + New_Else_Stmt (If_Blk); + -- Return state. + Open_Temp; + end if; + -- Copy-out non-composite parameters. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then Last_Individual := Pos; + declare + Assoc_Info : constant Call_Assoc_Info_Acc := Get_Info (El); + Formal_Type : Iir; + Base_Formal : Iir; + Ftype_Info : Type_Info_Acc; + Formal_Object_Kind : Object_Kind_Type; + begin + if Assoc_Info /= null then + Formal_Type := Get_Type (Get_Formal (El)); + Ftype_Info := Get_Info (Formal_Type); + Base_Formal := Get_Association_Interface (El); + Formal_Object_Kind := Get_Interface_Kind (Base_Formal); + declare + Param_Var : Var_Type; + begin + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + Param_Var := Assoc_Info.Call_Assoc_Fat; + else + Param_Var := Assoc_Info.Call_Assoc_Value; + end if; + Params (Pos) := Stabilize + (Get_Var (Param_Var, Ftype_Info, Formal_Object_Kind)); + end; + end if; + end; elsif Params (Pos) /= Mnode_Null then - Formal := Strip_Denoting_Name (Get_Formal (El)); - Base_Formal := Get_Association_Interface (El); - - pragma Assert (Get_Kind (Base_Formal) - = Iir_Kind_Interface_Variable_Declaration); - pragma Assert (Get_Mode (Base_Formal) in Iir_Out_Modes); - - Formal_Type := Get_Type (Formal); - Ftype_Info := Get_Info (Formal_Type); - Formal_Info := Get_Info (Base_Formal); - - -- Extract the value - if Base_Formal /= Formal then - -- By individual, copy back. - Param := Translate_Individual_Association_Formal - (Formal, Formal_Info, Params (Last_Individual)); - elsif Inout_Params (Pos) /= Mnode_Null then - Param := Inout_Params (Pos); - else - pragma Assert (Formal_Info.Interface_Field /= O_Fnode_Null); - Ptr := New_Selected_Element - (New_Obj (Params_Var), Formal_Info.Interface_Field); - Param := Lv2M (Ptr, Ftype_Info, Mode_Value); - end if; + declare + Assoc_Info : constant Call_Assoc_Info_Acc := Get_Info (El); + Formal : constant Iir := Strip_Denoting_Name (Get_Formal (El)); + Base_Formal : constant Iir := Get_Association_Interface (El); + Formal_Type : constant Iir := Get_Type (Formal); + Ftype_Info : constant Type_Info_Acc := Get_Info (Formal_Type); + Formal_Info : constant Ortho_Info_Acc := Get_Info (Base_Formal); + Act : Iir; + Actual_Type : Iir; + Param : Mnode; + Val : O_Enode; + Ptr : O_Lnode; + Out_Conv : Iir; + Out_Expr : Iir; + begin + pragma Assert (Get_Kind (Base_Formal) + = Iir_Kind_Interface_Variable_Declaration); + pragma Assert (Get_Mode (Base_Formal) in Iir_Out_Modes); + + -- Extract the value + if Base_Formal /= Formal then + -- By individual, copy back. + Param := Translate_Individual_Association_Formal + (Formal, Formal_Info, Params (Last_Individual)); + elsif Inout_Params (Pos) /= Mnode_Null then + Param := Inout_Params (Pos); + else + pragma Assert (Formal_Info.Interface_Field /= O_Fnode_Null); + Ptr := New_Selected_Element + (Get_Var (Params_Var), Formal_Info.Interface_Field); + case Type_Mode_Valid (Ftype_Info.Type_Mode) is + when Type_Mode_Pass_By_Copy => + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + when Type_Mode_Pass_By_Address => + Param := Lp2M (Ptr, Ftype_Info, Mode_Value); + end case; + end if; - Out_Conv := Get_Out_Conversion (El); - if Out_Conv = Null_Iir then - Out_Expr := Formal; - Val := M2E (Param); - else - Out_Expr := Out_Conv; - Val := Do_Conversion (Out_Conv, Formal, M2E (Param)); - end if; + Out_Conv := Get_Out_Conversion (El); + if Out_Conv = Null_Iir then + Out_Expr := Formal; + Val := M2E (Param); + else + Out_Expr := Out_Conv; + Val := Do_Conversion (Out_Conv, Formal, M2E (Param)); + end if; - Chap7.Translate_Assign - (Params (Pos), Val, Out_Expr, Get_Type (Get_Actual (El)), El); + Act := Get_Actual (El); + Actual_Type := Get_Type (Act); + if Assoc_Info = null then + Param := Params (Pos); + else + Param := Lp2M (Get_Var (Assoc_Info.Call_Assoc_Ref), + Get_Info (Actual_Type), Mode_Value); + end if; + Chap7.Translate_Assign (Param, Val, Out_Expr, Actual_Type, El); + end; end if; El := Get_Chain (El); Pos := Pos + 1; end loop; + if Is_Function or else Info.Subprg_Params_Type = O_Tnode_Null then + null; + else + if Is_Suspendable then + Close_Temp; + + -- Release stack2 memory. + Release_Stack2 (Get_Var (Call_Info.Call_State_Mark)); + + -- End of call. + State_Jump (Next_State); + Finish_If_Stmt (If_Blk); + State_Start (Next_State); + else + Release_Stack2 (Get_Var (Mark_Var)); + Finish_Declare_Stmt; + end if; + end if; + return O_Enode_Null; end Translate_Subprogram_Call; procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) is Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Imp : constant Iir := Get_Implementation (Stmt); Obj : constant Iir := Get_Method_Object (Stmt); Res : O_Enode; begin - Res := Translate_Subprogram_Call (Imp, Assoc_Chain, Obj); + Res := Translate_Subprogram_Call (Stmt, Assoc_Chain, Obj); pragma Assert (Res = O_Enode_Null); end Translate_Procedure_Call; @@ -2070,16 +3081,21 @@ package body Trans.Chap8 is Timeout : constant Iir := Get_Timeout_Clause (Stmt); Sensitivity : Iir_List; Constr : O_Assoc_List; + Resume_State : State_Type; begin Sensitivity := Get_Sensitivity_List (Stmt); - if Sensitivity = Null_Iir_List and Cond /= Null_Iir then - -- Extract sensitivity list. + -- Extract sensitivity from condition. Sensitivity := Create_Iir_List; Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); Set_Sensitivity_List (Stmt, Sensitivity); end if; + -- The wait statement must be within a suspendable process/subprogram. + pragma Assert (State_Enabled); + + Resume_State := State_Allocate; + -- Check for simple cases. if Sensitivity = Null_Iir_List and then Cond = Null_Iir @@ -2090,11 +3106,26 @@ package body Trans.Chap8 is New_Procedure_Call (Constr); else -- Wait for a timeout. + Open_Temp; Start_Association (Constr, Ghdl_Process_Wait_Timeout); New_Association (Constr, Chap7.Translate_Expression (Timeout, Time_Type_Definition)); New_Procedure_Call (Constr); + Close_Temp; + end if; + + -- Suspend. + State_Suspend (Resume_State); + + -- Resume point. + State_Start (Resume_State); + + if State_Debug and then Timeout = Null_Iir then + -- A process exit must not resume! + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Unreach_State); end if; + + -- End of simple cases. return; end if; @@ -2113,49 +3144,57 @@ package body Trans.Chap8 is Chap9.Destroy_Types_In_List (Sensitivity); end if; + -- suspend (); + -- FIXME: this just sets the state, could be done in Add_Sensitivity + -- or Set_Timeout. + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + New_Procedure_Call (Constr); + if Cond = Null_Iir then - declare - V : O_Dnode; - begin - -- declare - -- v : __ghdl_bool_type_node; - -- begin - -- v := suspend (); - -- end; - Open_Temp; - V := Create_Temp (Ghdl_Bool_Type); - Start_Association (Constr, Ghdl_Process_Wait_Suspend); - New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); - Close_Temp; - end; + State_Suspend (Resume_State); else declare - Label : O_Snode; + Eval_State : State_Type; + If_Blk1, If_Blk2 : O_If_Block; begin - -- start loop - Start_Loop_Stmt (Label); - - -- if suspend() then -- return true if timeout. - -- exit; - -- end if; - Start_Association (Constr, Ghdl_Process_Wait_Suspend); - Gen_Exit_When (Label, New_Function_Call (Constr)); - - -- if condition then - -- exit; - -- end if; + Eval_State := State_Allocate; + + State_Suspend (Eval_State); + + -- EVAL_STATE: + State_Start (Eval_State); + + -- if timed_out() then + -- GOTO RESUME_STATE; + -- else + Start_Association (Constr, Ghdl_Process_Wait_Timed_Out); + Start_If_Stmt (If_Blk1, New_Function_Call (Constr)); + State_Jump (Resume_State); + New_Else_Stmt (If_Blk1); + + -- if condition then + -- GOTO RESUME_STATE; + -- else + -- SUSPEND EVAL_STATE; + -- end if; Open_Temp; - Gen_Exit_When - (Label, + Start_If_Stmt + (If_Blk2, Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); + State_Jump (Resume_State); + New_Else_Stmt (If_Blk2); + State_Suspend (Eval_State); + Finish_If_Stmt (If_Blk2); Close_Temp; - -- end loop; - Finish_Loop_Stmt (Label); + -- end if; + Finish_If_Stmt (If_Blk1); end; end if; - -- wait_close; + -- RESUME_STATE: + -- wait_close; + State_Start (Resume_State); Start_Association (Constr, Ghdl_Process_Wait_Close); New_Procedure_Call (Constr); end Translate_Wait_Statement; @@ -2979,7 +4018,12 @@ package body Trans.Chap8 is Call : constant Iir := Get_Procedure_Call (Stmt); Imp : constant Iir := Get_Implementation (Call); begin - Canon.Canon_Subprogram_Call (Call); + if not Get_Suspend_Flag (Stmt) then + -- Suspendable calls were already canonicalized. + Canon.Canon_Subprogram_Call (Call); + Trans.Update_Node_Infos; + end if; + if Is_Implicit_Subprogram (Imp) then Translate_Implicit_Procedure_Call (Call); else diff --git a/src/vhdl/translate/trans-chap8.ads b/src/vhdl/translate/trans-chap8.ads index 27ddfe8..94755d3 100644 --- a/src/vhdl/translate/trans-chap8.ads +++ b/src/vhdl/translate/trans-chap8.ads @@ -17,11 +17,49 @@ -- 02111-1307, USA. package Trans.Chap8 is + -- If TRUE, generate extra-code to catch at run-time incoherent state + -- issues. + State_Debug : constant Boolean := True; + + -- The initial state. Used in process to loop. + State_Init : constant State_Type := 0; + + -- The state for 'return' in a subprogram. + State_Return : constant State_Type := 1; + + -- Called at the entry of the generated procedure to setup the state + -- machinery: set the local state variable, create the state machine + -- (loop, case, first choice). The current position in the graph is + -- vertex 0 (initial state): there is an implicit State_Allocate and a + -- State_Start. This is not reentrant (does not nest). + procedure State_Entry (Info : Ortho_Info_Acc); + + -- Last action of the generated procedure: close the case and the loop. + -- Destroy the state machinery. + procedure State_Leave (Parent : Iir); + + -- True if the current process or subprogram is state based. + function State_Enabled return Boolean; + + -- Create a new state. + function State_Allocate return State_Type; + + -- Start statements for STATE. + procedure State_Start (State : State_Type); + + -- Jump to state NEXT_STATE. Note: this doesn't modify the control flow, + -- so there must be no statements after State_Jump until the next + -- State_Start. + procedure State_Jump (Next_State : State_Type); + + -- Suspend the current process or subprogram. It will resume to + -- NEXT_STATE. + procedure State_Suspend (Next_State : State_Type); + procedure Translate_Statements_Chain (First : Iir); -- Return true if there is a return statement in the chain. - function Translate_Statements_Chain_Has_Return (First : Iir) - return Boolean; + function Translate_Statements_Chain_Has_Return (First : Iir) return Boolean; -- Create a case branch for CHOICE. -- Used by case statement and aggregates. @@ -35,8 +73,14 @@ package Trans.Chap8 is Val : Unsigned_64; Itype : Iir); + -- Create declarations for a for-loop statement. + procedure Translate_For_Loop_Statement_Declaration (Stmt : Iir); + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); - function Translate_Subprogram_Call (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) - return O_Enode; + -- Create the state record for the CALL procedure call. + procedure Translate_Procedure_Call_State (Call : Iir); + + function Translate_Subprogram_Call + (Call : Iir; Assoc_Chain : Iir; Obj : Iir) return O_Enode; end Trans.Chap8; diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index d96ad6f..0736c6d 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -97,7 +97,10 @@ package body Trans.Chap9 is procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) is + use Trans.Chap8; Info : constant Proc_Info_Acc := Get_Info (Proc); + Is_Non_Sensitized : constant Boolean := + Get_Kind (Proc) = Iir_Kind_Process_Statement; Inter_List : O_Inter_List; Instance : O_Dnode; begin @@ -112,9 +115,18 @@ package body Trans.Chap9 is -- Push scope for architecture declarations. Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + if Is_Non_Sensitized then + Chap8.State_Entry (Info); + end if; + Chap8.Translate_Statements_Chain (Get_Sequential_Statement_Chain (Proc)); + if Is_Non_Sensitized then + Chap8.State_Jump (State_Init); + Chap8.State_Leave (Proc); + end if; + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; @@ -232,6 +244,19 @@ package body Trans.Chap9 is Push_Instance_Factory (Info.Process_Scope'Access); Chap4.Translate_Declaration_Chain (Proc); + if Get_Kind (Proc) = Iir_Kind_Process_Statement then + -- The state variable. + Info.Process_State := Create_Var (Create_Var_Identifier ("STATE"), + Ghdl_Index_Type, O_Storage_Local); + + -- Add declarations for statements (iterator, call) and state. + Chap4.Translate_Statements_Chain_State_Declaration + (Get_Sequential_Statement_Chain (Proc), + Info.Process_Locvar_Scope'Access); + + Add_Scope_Field (Wki_Locvars, Info.Process_Locvar_Scope); + end if; + if Flag_Direct_Drivers then -- Create direct drivers. Drivers := Trans_Analyzes.Extract_Drivers (Proc); @@ -1311,6 +1336,10 @@ package body Trans.Chap9 is if List_Orig = Iir_List_All then Destroy_Iir_List (List); end if; + else + -- Initialize state. + New_Assign_Stmt + (Get_Var (Info.Process_State), New_Lit (Ghdl_Index_0)); end if; end Elab_Process; diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb index 9a4b285..6b8b28b 100644 --- a/src/vhdl/translate/trans-helpers2.adb +++ b/src/vhdl/translate/trans-helpers2.adb @@ -26,8 +26,7 @@ with Trans.Foreach_Non_Composite; package body Trans.Helpers2 is use Trans.Helpers; - procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) - is + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) is begin New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), M2Addr (Chap3.Get_Array_Base (S))); diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb index e8ba4a0..c6cbd50 100644 --- a/src/vhdl/translate/trans.adb +++ b/src/vhdl/translate/trans.adb @@ -349,6 +349,14 @@ package body Trans is Pop_Build_Instance; end Pop_Local_Factory; + procedure Create_Union_Scope + (Scope : out Var_Scope_Type; Stype : O_Tnode) is + begin + pragma Assert (Scope.Scope_Type = O_Tnode_Null); + pragma Assert (Scope.Kind = Var_Scope_None); + Scope.Scope_Type := Stype; + end Create_Union_Scope; + procedure Set_Scope_Via_Field (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is @@ -1748,6 +1756,23 @@ package body Trans is Finish_If_Stmt (If_Blk); end Gen_Exit_When; + procedure Set_Stack2_Mark (Var : O_Lnode) + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Stack2_Mark); + New_Assign_Stmt (Var, New_Function_Call (Constr)); + end Set_Stack2_Mark; + + procedure Release_Stack2 (Var : O_Lnode) + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Stack2_Release); + New_Association (Constr, New_Value (Var)); + New_Procedure_Call (Constr); + end Release_Stack2; + -- Create a temporary variable. type Temp_Level_Type; type Temp_Level_Acc is access Temp_Level_Type; @@ -1765,6 +1790,9 @@ package body Trans is -- first use. Emitted : Boolean; + -- If true, do not mark/release stack2. + No_Stack2_Mark : Boolean; + -- Declaration of the variable for the stack2 mark. The stack2 will -- be released at the end of the scope (if used). Stack2_Mark : O_Dnode; @@ -1783,27 +1811,39 @@ package body Trans is is L : Temp_Level_Acc; begin + -- Allocate a new record. if Old_Level /= null then + -- From unused ones. L := Old_Level; Old_Level := L.Prev; else + -- No unused, create a new one. L := new Temp_Level_Type; end if; + L.all := (Prev => Temp_Level, Level => 0, Id => 0, Emitted => False, + No_Stack2_Mark => False, Stack2_Mark => O_Dnode_Null); if Temp_Level /= null then L.Level := Temp_Level.Level + 1; end if; Temp_Level := L; + if Flag_Debug_Temp then New_Debug_Comment_Stmt ("Open_Temp level " & Natural'Image (L.Level)); end if; end Open_Temp; + procedure Disable_Stack2_Release is + begin + pragma Assert (not Temp_Level.No_Stack2_Mark); + Temp_Level.No_Stack2_Mark := True; + end Disable_Stack2_Release; + procedure Open_Local_Temp is begin Open_Temp; @@ -1815,15 +1855,10 @@ package body Trans is return Temp_Level.Stack2_Mark /= O_Dnode_Null; end Has_Stack2_Mark; - procedure Stack2_Release - is - Constr : O_Assoc_List; + procedure Stack2_Release is begin if Temp_Level.Stack2_Mark /= O_Dnode_Null then - Start_Association (Constr, Ghdl_Stack2_Release); - New_Association (Constr, - New_Value (New_Obj (Temp_Level.Stack2_Mark))); - New_Procedure_Call (Constr); + Release_Stack2 (New_Obj (Temp_Level.Stack2_Mark)); Temp_Level.Stack2_Mark := O_Dnode_Null; end if; end Stack2_Release; @@ -1832,10 +1867,9 @@ package body Trans is is L : Temp_Level_Acc; begin - if Temp_Level = null then - -- OPEN_TEMP was not called. - raise Internal_Error; - end if; + -- Check that OPEN_TEMP was called. + pragma Assert (Temp_Level /= null); + if Flag_Debug_Temp then New_Debug_Comment_Stmt ("Close_Temp level " & Natural'Image (Temp_Level.Level)); @@ -1879,9 +1913,7 @@ package body Trans is end loop; end Free_Old_Temp; - procedure Create_Temp_Stack2_Mark - is - Constr : O_Assoc_List; + procedure Create_Temp_Stack2_Mark is begin if Temp_Level.Stack2_Mark /= O_Dnode_Null then -- Only the first mark in a region is registred. @@ -1889,10 +1921,14 @@ package body Trans is -- first mark. return; end if; + + if Temp_Level.No_Stack2_Mark then + -- Stack2 mark and release was explicitely disabled. + return; + end if; + Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); - Start_Association (Constr, Ghdl_Stack2_Mark); - New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), - New_Function_Call (Constr)); + Set_Stack2_Mark (New_Obj (Temp_Level.Stack2_Mark)); end Create_Temp_Stack2_Mark; function Create_Temp (Atype : O_Tnode) return O_Dnode diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index 47c050b..e9a66c1 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -159,6 +159,7 @@ package Trans is Wki_R_Len : O_Ident; Wki_Base : O_Ident; Wki_Bounds : O_Ident; + Wki_Locvars : O_Ident; -- ALLOCATION_KIND defines the type of memory storage. -- ALLOC_STACK means the object is allocated on the local stack and @@ -270,9 +271,14 @@ package Trans is -- Destroy a local scope. procedure Pop_Local_Factory; + -- Create a special scope for declarations in statements. The scope + -- structure is opaque (typically a union). + procedure Create_Union_Scope + (Scope : out Var_Scope_Type; Stype : O_Tnode); + -- Set_Scope defines how to access to variables of SCOPE. -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD - -- in scope SCOPE_PARENT. + -- of scope SCOPE_PARENT. procedure Set_Scope_Via_Field (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); @@ -642,6 +648,8 @@ package Trans is Kind_Index, Kind_Expr, Kind_Subprg, + Kind_Call, + Kind_Call_Assoc, Kind_Object, Kind_Signal, Kind_Alias, @@ -651,6 +659,8 @@ package Trans is Kind_Process, Kind_Psl_Directive, Kind_Loop, + Kind_Loop_State, + Kind_Locvar_State, Kind_Block, Kind_Generate, Kind_Component, @@ -659,7 +669,6 @@ package Trans is Kind_Package_Instance, Kind_Config, Kind_Assoc, - Kind_Str_Choice, Kind_Design_File, Kind_Library ); @@ -915,6 +924,12 @@ package Trans is end record; type Subprg_Resolv_Info_Acc is access Subprg_Resolv_Info; + -- In order to support resume feature of non-sensitized processes and + -- procedure, a state variable is added to encode vertices of the control + -- flow graph (only suspendable vertices are considered: an inner loop + -- that doesn't suspend is not decomposed by this mechanism). + type State_Type is new Nat32; + -- Complex types. -- -- A complex type is not a VHDL notion, but a translation notion. @@ -1151,6 +1166,15 @@ package Trans is Subprg_Params_Type : O_Tnode := O_Tnode_Null; Subprg_Params_Ptr : O_Tnode := O_Tnode_Null; + -- Field in the parameter struct for the suspend state. Also the + -- suspend state is not a parameter, it is initialized by the + -- caller. + Subprg_State_Field : O_Fnode := O_Fnode_Null; + + -- Field in the parameter struct for local variables. + Subprg_Locvars_Field : O_Fnode := O_Fnode_Null; + Subprg_Locvars_Scope : aliased Var_Scope_Type; + -- Access to the declarations within this subprogram. Subprg_Frame_Scope : aliased Var_Scope_Type; @@ -1169,6 +1193,21 @@ package Trans is Subprg_Exit : O_Snode := O_Snode_Null; Subprg_Result : O_Dnode := O_Dnode_Null; + when Kind_Call => + Call_State_Scope : aliased Var_Scope_Type; + Call_State_Mark : Var_Type := Null_Var; + Call_Frame_Var : Var_Type := Null_Var; + + when Kind_Call_Assoc => + -- Variable containing a reference to the actual, for scalar + -- copyout. The value is passed in the parameter. + Call_Assoc_Ref : Var_Type := Null_Var; + + -- Variable containing the value, the bounds and the fat vector. + Call_Assoc_Value : Var_Type := Null_Var; + Call_Assoc_Bounds : Var_Type := Null_Var; + Call_Assoc_Fat : Var_Type := Null_Var; + when Kind_Object => -- For constants: set when the object is defined as a constant. Object_Static : Boolean; @@ -1195,7 +1234,14 @@ package Trans is Alias_Kind : Object_Kind_Type; when Kind_Iterator => + -- Iterator variable. Iterator_Var : Var_Type; + -- Iterator right bound (used only if the iterator is a range + -- expression). + Iterator_Right : Var_Type; + -- Iterator range pointer (used only if the iterator is not a + -- range expression). + Iterator_Range : Var_Type; when Kind_Interface => -- Ortho declaration for the interface. If not null, there is @@ -1226,6 +1272,13 @@ package Trans is -- Subprogram for the process. Process_Subprg : O_Dnode; + -- Variable (in the frame) containing the current state (a + -- number) used to resume the process. + Process_State : Var_Type := Null_Var; + + -- Union containing local declarations for statements. + Process_Locvar_Scope : aliased Var_Scope_Type; + -- List of drivers if Flag_Direct_Drivers. Process_Drivers : Direct_Drivers_Acc := null; @@ -1262,6 +1315,22 @@ package Trans is -- Used to next from for-loop, with an exit statment. Label_Next : O_Snode; + when Kind_Loop_State => + -- Likewise but for a suspendable loop. + -- State next: evaluate condition for a while-loop, update + -- iterator for a for-loop. + Loop_State_Next : State_Type; + -- Body of a for-loop, not used for a while-loop. + Loop_State_Body: State_Type; + -- State after the loop. + Loop_State_Exit : State_Type; + -- Access to declarations of the iterator. + Loop_State_Scope : aliased Var_Scope_Type; + Loop_Locvar_Scope : aliased Var_Scope_Type; + + when Kind_Locvar_State => + Locvar_Scope : aliased Var_Scope_Type; + when Kind_Block => -- Access to declarations of this block. Block_Scope : aliased Var_Scope_Type; @@ -1400,16 +1469,6 @@ package Trans is Assoc_In : Assoc_Conv_Info; Assoc_Out : Assoc_Conv_Info; - when Kind_Str_Choice => - -- List of choices, used to sort them. - Choice_Chain : Ortho_Info_Acc; - -- Association index. - Choice_Assoc : Natural; - -- Corresponding choice simple expression. - Choice_Expr : Iir; - -- Corresponding choice. - Choice_Parent : Iir; - when Kind_Design_File => Design_Filename : O_Dnode; @@ -1425,12 +1484,15 @@ package Trans is subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type); subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index); subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); + subtype Call_Info_Acc is Ortho_Info_Acc (Kind_Call); + subtype Call_Assoc_Info_Acc is Ortho_Info_Acc (Kind_Call_Assoc); subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); subtype Signal_Info_Acc is Ortho_Info_Acc (Kind_Signal); subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive); subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); + subtype Loop_State_Info_Acc is Ortho_Info_Acc (Kind_Loop_State); 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); @@ -1692,6 +1754,10 @@ package Trans is -- Generate code to exit from loop LABEL iff COND is true. procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); + -- Low-level stack2 mark and release. + procedure Set_Stack2_Mark (Var : O_Lnode); + procedure Release_Stack2 (Var : O_Lnode); + -- Create a region for temporary variables. The region is only created -- on demand (at the first Create_Temp*), so you must be careful not -- to nest with control statement. For example, the following @@ -1735,6 +1801,11 @@ package Trans is -- Manually release stack2. Used for fine-tuning only. procedure Stack2_Release; + -- Used only in procedure calls to disable the release of stack2, as + -- it might be part of the state of the call. Must be called just after + -- Open_Temp. + procedure Disable_Stack2_Release; + -- Free all old temp. -- Used only to free memory. procedure Free_Old_Temp; diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads index e2c87f0..270442e 100644 --- a/src/vhdl/translate/trans_decls.ads +++ b/src/vhdl/translate/trans_decls.ads @@ -44,6 +44,7 @@ package Trans_Decls is Ghdl_Process_Wait_Set_Timeout : O_Dnode; Ghdl_Process_Wait_Add_Sensitivity : O_Dnode; Ghdl_Process_Wait_Suspend : O_Dnode; + Ghdl_Process_Wait_Timed_Out : O_Dnode; Ghdl_Process_Wait_Close : O_Dnode; -- Register a sensitivity for a process. diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index a3d2375..d837584 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -392,6 +392,7 @@ package body Translation is Wki_R_Len := Get_Identifier ("r_len"); Wki_Base := Get_Identifier ("BASE"); Wki_Bounds := Get_Identifier ("BOUNDS"); + Wki_Locvars := Get_Identifier ("LOCVARS"); Sizetype := New_Unsigned_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); @@ -1676,12 +1677,18 @@ package body Translation is New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity); - -- function __ghdl_process_wait_suspend return __ghdl_bool_type; - Start_Function_Decl + -- procedure __ghdl_process_wait_suspend (void); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"), - O_Storage_External, Ghdl_Bool_Type); + O_Storage_External); Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend); + -- function __ghdl_process_wait_timed_out return __ghdl_bool_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_timed_out"), + O_Storage_External, Ghdl_Bool_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timed_Out); + -- void __ghdl_process_wait_close (void); Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_process_wait_close"), |