-- Iir to ortho translator. -- Copyright (C) 2002 - 2014 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -- WARRANTY; without even the implied warranty of MERCHANTABILITY or -- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- for more details. -- -- You should have received a copy of the GNU General Public License -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; with Std_Names; with Errorout; use Errorout; with Iir_Chains; with Canon; with Evaluation; use Evaluation; with Std_Package; use Std_Package; with Iirs_Utils; use Iirs_Utils; with Trans.Chap2; with Trans.Chap3; with Trans.Chap4; with Trans.Chap6; with Trans.Chap7; with Trans.Chap9; with Trans.Chap14; with Trans_Decls; use Trans_Decls; with Translation; use Translation; with Trans.Helpers2; use Trans.Helpers2; 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 := Get_Info (Chap2.Current_Subprogram); Expr : constant Iir := Get_Expression (Stmt); Ret_Type : Iir; Ret_Info : Type_Info_Acc; procedure Gen_Return is begin if Subprg_Info.Subprg_Exit /= O_Snode_Null then New_Exit_Stmt (Subprg_Info.Subprg_Exit); else New_Return_Stmt; end if; end Gen_Return; procedure Gen_Return_Value (Val : O_Enode) is begin if Subprg_Info.Subprg_Exit /= O_Snode_Null then New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); New_Exit_Stmt (Subprg_Info.Subprg_Exit); else New_Return_Stmt (Val); end if; end Gen_Return_Value; begin if Expr = Null_Iir then -- Return in a procedure. if Get_Suspend_Flag (Chap2.Current_Subprogram) then State_Jump (State_Return); State_Jump_Force; else Gen_Return; end if; return; end if; -- Return in a function. Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); Ret_Info := Get_Info (Ret_Type); case Ret_Info.Type_Mode is when Type_Mode_Scalar => -- * if the return type is scalar, simply returns. declare V : O_Dnode; R : O_Enode; begin -- Always uses a temporary in case of the return expression -- 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 or else Chap3.Need_Range_Check (Expr, Ret_Type) then V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (V), R); Stack2_Release; Chap3.Check_Range (V, Expr, Ret_Type, Expr); Gen_Return_Value (New_Obj_Value (V)); else Gen_Return_Value (R); end if; end; when Type_Mode_Acc | Type_Mode_Bounds_Acc => -- * access: no range. declare Res : O_Enode; begin Res := Chap7.Translate_Expression (Expr, Ret_Type); Gen_Return_Value (Res); end; when Type_Mode_Fat_Array => -- * if the return type is unconstrained: allocate an area from -- the secondary stack, copy it to the area, and fill the fat -- pointer. -- Evaluate the result. declare Val : Mnode; Area : Mnode; begin Area := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); Val := Stabilize (E2M (Chap7.Translate_Expression (Expr, Ret_Type), Ret_Info, Mode_Value)); Chap3.Translate_Object_Allocation (Area, Alloc_Return, Ret_Type, Chap3.Get_Array_Bounds (Val)); Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); Gen_Return; end; when Type_Mode_Record | Type_Mode_Array => -- * if the return type is a constrained composite type, copy -- it to the result area. -- Create a temporary area so that if the expression use -- stack2, it will be freed before the return (otherwise, -- the stack area will be lost). declare V : Mnode; begin Open_Temp; V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); Chap3.Translate_Object_Copy (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); Close_Temp; Gen_Return; end; when Type_Mode_File | Type_Mode_Unknown | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Return_Statement; 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; begin Start_If_Stmt (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); Else_Clause := Get_Else_Clause (Stmt); if Else_Clause /= Null_Iir then New_Else_Stmt (Blk); if Get_Condition (Else_Clause) = Null_Iir then Translate_Statements_Chain (Get_Sequential_Statement_Chain (Else_Clause)); else Open_Temp; 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) return O_Enode is begin return New_Value (New_Selected_Element (New_Access_Element (New_Value (O_Range)), Field)); end Get_Range_Ptr_Field_Value; -- Inc or dec ITERATOR according to DIR. procedure Gen_Update_Iterator_Common (Val : Unsigned_64; Itype : Iir; V : out O_Enode) is Base_Type : constant Iir := Get_Base_Type (Itype); begin case Get_Kind (Base_Type) is when Iir_Kind_Integer_Type_Definition => V := New_Lit (New_Signed_Literal (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); when Iir_Kind_Enumeration_Type_Definition => declare List : Iir_List; begin List := Get_Enumeration_Literal_List (Base_Type); -- FIXME: what about type E is ('T') ?? if Natural (Val) > Get_Nbr_Elements (List) then raise Internal_Error; end if; V := New_Lit (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); end; 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; 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 Translate_For_Loop_Statement_Declaration (Stmt : Iir) is 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 -- Iterator range. Chap3.Translate_Object_Subtype (Iterator, False); -- 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); 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; 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 (It_Info.Iterator_Var), Chap7.Translate_Range_Expression_Left (Constraint, Iter_Base_Type)); Dir := Get_Direction (Constraint); New_Assign_Stmt (Get_Var (It_Info.Iterator_Right), Chap7.Translate_Range_Expression_Right (Constraint, Iter_Base_Type)); case Dir is when Iir_To => Op := ON_Le; when Iir_Downto => Op := ON_Ge; end case; -- Check for at least one iteration. Cond := New_Compare_Op (Op, New_Value (Get_Var (It_Info.Iterator_Var)), New_Value (Get_Var (It_Info.Iterator_Right)), Ghdl_Bool_Type); else 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)); New_Assign_Stmt (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 (Get_Var (It_Info.Iterator_Range), Iter_Type_Info.T.Range_Length), New_Lit (Ghdl_Index_0), Ghdl_Bool_Type); end if; end Start_For_Loop; procedure Exit_Cond_For_Loop (Iterator : Iir; 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); Val : O_Enode; begin -- Check end of loop. -- Equality is necessary and enough. if Get_Kind (Constraint) = Iir_Kind_Range_Expression then Val := New_Value (Get_Var (It_Info.Iterator_Right)); else Val := Get_Range_Ptr_Field_Value (Get_Var (It_Info.Iterator_Range), Iter_Type_Info.T.Range_Right); end if; 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 (It_Info.Iterator_Var, Iir_To, 1, Iter_Base_Type); else 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 (Get_Var (It_Info.Iterator_Range), Iter_Type_Info.T.Range_Dir), New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); Gen_Update_Iterator (It_Info.Iterator_Var, Iir_To, 1, Iter_Base_Type); New_Else_Stmt (If_Blk1); 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); 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; -- Loop body. State_Start (Info.Loop_State_Body); Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); State_Jump (Info.Loop_State_Next); -- 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); -- 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); 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 Start_Declare_Stmt; Open_Temp; Translate_For_Loop_Statement_Declaration (Stmt); -- Loop header: initialize iterator. Start_For_Loop (Iterator, Cond); -- 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)); -- 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) is Cond : constant Iir := Get_Condition (Stmt); Prev_Loop : Iir; begin Prev_Loop := Current_Loop; Current_Loop := Stmt; 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; -- NEXT_STATE: State_Jump (Info.Loop_State_Next); State_Start (Info.Loop_State_Next); if Cond /= Null_Iir then Info.Loop_State_Body := State_Allocate; -- 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; Free_Info (Stmt); Current_Loop := Prev_Loop; end Translate_While_Loop_Statement; procedure Translate_Exit_Next_Statement (Stmt : Iir) is Cond : constant Iir := Get_Condition (Stmt); If_Blk : O_If_Block; Info : Ortho_Info_Acc; Loop_Label : Iir; Loop_Stmt : Iir; begin Loop_Label := Get_Loop_Label (Stmt); if Loop_Label = Null_Iir then Loop_Stmt := Current_Loop; else Loop_Stmt := Get_Named_Entity (Loop_Label); end if; Info := Get_Info (Loop_Stmt); -- Common part. if Cond /= Null_Iir then 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; procedure Translate_Variable_Aggregate_Assignment (Targ : Iir; Targ_Type : Iir; Val : Mnode); procedure Translate_Variable_Array_Aggr (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode; Index : in out Unsigned_64; Dim : Natural) is El : Iir; Final : Boolean; El_Type : Iir; begin Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); if Final then El_Type := Get_Element_Subtype (Targ_Type); end if; El := Get_Association_Choices_Chain (Targ); while El /= Null_Iir loop case Get_Kind (El) is when Iir_Kind_Choice_By_None => if Final then Translate_Variable_Aggregate_Assignment (Get_Associated_Expr (El), El_Type, Chap3.Index_Base (Val, Targ_Type, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Index)))); Index := Index + 1; else Translate_Variable_Array_Aggr (Get_Associated_Expr (El), Targ_Type, Val, Index, Dim + 1); end if; when others => Error_Kind ("translate_variable_array_aggr", El); end case; El := Get_Chain (El); end loop; end Translate_Variable_Array_Aggr; procedure Translate_Variable_Rec_Aggr (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) is Aggr_El : Iir; El_List : Iir_List; El_Index : Natural; Elem : Iir; begin El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Targ); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => Elem := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Elem := Get_Choice_Name (Aggr_El); when others => Error_Kind ("translate_variable_rec_aggr", Aggr_El); end case; Translate_Variable_Aggregate_Assignment (Get_Associated_Expr (Aggr_El), Get_Type (Elem), Chap6.Translate_Selected_Element (Val, Elem)); Aggr_El := Get_Chain (Aggr_El); end loop; end Translate_Variable_Rec_Aggr; procedure Translate_Variable_Aggregate_Assignment (Targ : Iir; Targ_Type : Iir; Val : Mnode) is Index : Unsigned_64; begin if Get_Kind (Targ) = Iir_Kind_Aggregate then case Get_Kind (Targ_Type) is when Iir_Kinds_Array_Type_Definition => Index := 0; Translate_Variable_Array_Aggr (Targ, Targ_Type, Val, Index, 1); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); when others => Error_Kind ("translate_variable_aggregate_assignment", Targ_Type); end case; else declare Targ_Node : Mnode; begin Targ_Node := Chap6.Translate_Name (Targ); Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); end; end if; end Translate_Variable_Aggregate_Assignment; procedure Translate_Variable_Assignment_Statement (Stmt : Iir_Variable_Assignment_Statement) is Target : constant Iir := Get_Target (Stmt); Targ_Type : constant Iir := Get_Type (Target); Expr : constant Iir := Get_Expression (Stmt); Targ_Node : Mnode; begin if Get_Kind (Target) = Iir_Kind_Aggregate then declare E : O_Enode; Temp : Mnode; begin Chap3.Translate_Anonymous_Type_Definition (Targ_Type); -- Use a temporary variable, to avoid overlap. Temp := Create_Temp (Get_Info (Targ_Type)); Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); E := Chap7.Translate_Expression (Expr, Targ_Type); Chap3.Translate_Object_Copy (Temp, E, Targ_Type); Translate_Variable_Aggregate_Assignment (Target, Targ_Type, Temp); return; end; else Targ_Node := Chap6.Translate_Name (Target); if Get_Kind (Expr) = Iir_Kind_Aggregate then declare E : O_Enode; begin E := Chap7.Translate_Expression (Expr, Targ_Type); Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); end; else Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); end if; end if; end Translate_Variable_Assignment_Statement; procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) is Expr : Iir; Msg : O_Enode; Severity : O_Enode; Assocs : O_Assoc_List; Loc : O_Dnode; begin Loc := Chap4.Get_Location (Stmt); Expr := Get_Report_Expression (Stmt); if Expr = Null_Iir then Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); else Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); end if; Expr := Get_Severity_Expression (Stmt); if Expr = Null_Iir then Severity := New_Lit (Get_Ortho_Expr (Level)); else Severity := Chap7.Translate_Expression (Expr); end if; -- Do call. Start_Association (Assocs, Subprg); New_Association (Assocs, Msg); New_Association (Assocs, Severity); New_Association (Assocs, New_Address (New_Obj (Loc), Ghdl_Location_Ptr_Node)); New_Procedure_Call (Assocs); end Translate_Report; -- Return True if the current library unit is part of library IEEE. function Is_Within_Ieee_Library return Boolean is Design_File : Iir; Library : Iir; begin -- Guard. if Current_Library_Unit = Null_Iir then return False; end if; Design_File := Get_Design_File (Get_Design_Unit (Current_Library_Unit)); Library := Get_Library (Design_File); return Get_Identifier (Library) = Std_Names.Name_Ieee; end Is_Within_Ieee_Library; procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) is Expr : Iir; If_Blk : O_If_Block; Subprg : O_Dnode; begin -- Select the procedure to call in case of assertion (so that -- assertions within the IEEE library could be ignored). if Is_Within_Ieee_Library then Subprg := Ghdl_Ieee_Assert_Failed; else Subprg := Ghdl_Assert_Failed; end if; Expr := Get_Assertion_Condition (Stmt); if Get_Expr_Staticness (Expr) = Locally and then not Is_Overflow_Literal (Expr) then if Eval_Pos (Expr) = 1 then -- Assert TRUE is a noop. -- FIXME: generate a noop ? return; end if; Translate_Report (Stmt, Subprg, Severity_Level_Error); else -- An assertion is reported if the condition is false! Start_If_Stmt (If_Blk, New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Expr))); -- Note: it is necessary to create a declare block, to avoid bad -- order with the if block. Open_Temp; Translate_Report (Stmt, Subprg, Severity_Level_Error); Close_Temp; Finish_If_Stmt (If_Blk); end if; end Translate_Assertion_Statement; procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is begin Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); end Translate_Report_Statement; -- Helper to compare a string choice with the selector. function Translate_Simple_String_Choice (Expr : O_Dnode; Val : O_Enode; Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Func : Iir) 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); 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))); return New_Function_Call (Assoc); end Translate_Simple_String_Choice; -- Helper to evaluate the selector and preparing a choice variable. procedure Translate_String_Case_Statement_Common (Stmt : Iir_Case_Statement; Expr_Type : out Iir; Tinfo : out Type_Info_Acc; Expr_Node : out O_Dnode; C_Node : out O_Dnode) is 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_Type := Get_Type (Expr); Base_Type := Get_Base_Type (Expr_Type); Tinfo := Get_Info (Base_Type); -- Translate selector. Expr_Node := Create_Temp_Init (Tinfo.Ortho_Ptr_Type (Mode_Value), Chap7.Translate_Expression (Expr, Base_Type)); -- Copy the bounds for the choices. C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Selected_Element (New_Obj (C_Node), Tinfo.T.Bounds_Field (Mode_Value)), New_Value_Selected_Acc_Value (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; 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; Choice : Iir; Has_Others : Boolean; Func : Iir; -- Number of associations. Nbr_Assocs : Natural; Sel_Length : Iir_Int64; -- Dichotomy table (table of choices). String_Type : O_Tnode; Table_Base_Type : O_Tnode; Table_Type : O_Tnode; Table : O_Dnode; List : O_Array_Aggr_List; Table_Cst : O_Cnode; -- Association table. -- Indexed by the choice, returns an index to the associated -- statement list. -- Could be replaced by jump table. Assoc_Table_Base_Type : O_Tnode; Assoc_Table_Type : O_Tnode; Assoc_Table : O_Dnode; begin -- Fill Choices_Info array, and count number of associations. Last := No_Choice_Id; Nbr_Assocs := 0; Has_Others := False; Choice := Choices_Chain; while Choice /= Null_Iir loop 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; 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 : Choice_Id; Nbr : Natural; Res : out Choice_Id; Next : out Choice_Id) is 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! if Nbr < 2 then Res := Head; if Nbr = 0 then Next := Head; else 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 := No_Choice_Id; loop if L /= L_End and then (R = R_End or else Compare_String_Literals (Choices_Info (L).Choice_Expr, Choices_Info (R).Choice_Expr) = Compare_Lt) then -- Pick L. E := L; L := Choices_Info (L).Choice_Chain; elsif R /= R_End then -- Pick R. E := R; R := Choices_Info (R).Choice_Chain; else exit; end if; -- Append. if Last = No_Choice_Id then Res := E; else Choices_Info (Last).Choice_Chain := E; end if; Last := E; end loop; Choices_Info (Last).Choice_Chain := R_End; end Merge_Sort; begin 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 the sorted array of choices. Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Expr_Type)); String_Type := New_Constrained_Array_Type (Tinfo.T.Base_Type (Mode_Value), New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); Table_Type := New_Constrained_Array_Type (Table_Base_Type, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); New_Type_Decl (Create_Uniq_Identifier, Table_Type); New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, Table_Type); Start_Const_Value (Table); Start_Array_Aggr (List, Table_Type); El := First; while El /= No_Choice_Id loop New_Array_Aggr_El (List, Chap7.Translate_Static_Expression (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 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); Assoc_Table_Type := New_Constrained_Array_Type (Assoc_Table_Base_Type, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, O_Storage_Private, Assoc_Table_Type); Start_Const_Value (Assoc_Table); Start_Array_Aggr (List, Assoc_Table_Type); El := First; while El /= No_Choice_Id loop New_Array_Aggr_El (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); -- Generate dichotomy code. declare Var_Lo, Var_Hi, Var_Mid : O_Dnode; Var_Cmp : O_Dnode; Label : O_Snode; If_Blk1, If_Blk2 : O_If_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); New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); 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), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices - 1)))); Func := Chap7.Find_Predefined_Function (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); if Has_Others then Others_Lit := New_Unsigned_Literal (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_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)), 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_Assign_Stmt (New_Obj (Var_Idx), New_Value (New_Indexed_Element (New_Obj (Assoc_Table), 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)); Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Le, 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 New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); New_Exit_Stmt (Label); end if; 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))); Finish_If_Stmt (If_Blk2); New_Else_Stmt (If_Blk1); Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Ge, 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 New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); New_Exit_Stmt (Label); end if; 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))); Finish_If_Stmt (If_Blk2); Finish_If_Stmt (If_Blk1); 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 when Iir_Kind_Choice_By_Others => Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, Others_Lit); Finish_Choice (Case_Blk); 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 (Nbr_Assocs))); Finish_Choice (Case_Blk); 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; when others => raise Internal_Error; end case; Choice := Get_Chain (Choice); end loop; Start_Choice (Case_Blk); New_Default_Choice (Case_Blk); Finish_Choice (Case_Blk); 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; -- Case statement whose expression is an unidim array. -- Translate into if/elsif statements (linear search). 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; -- Node containing the current choice. Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Cond_Var : O_Dnode; Func : Iir; procedure Translate_String_Choice (Choice : Iir) is Cond : O_Enode; If_Blk : O_If_Block; Stmt_Chain : Iir; First : Boolean; Ch : Iir; Ch_Expr : Iir; begin if Choice = Null_Iir then return; end if; First := True; Stmt_Chain := Get_Associated_Chain (Choice); Ch := Choice; loop case Get_Kind (Ch) is when Iir_Kind_Choice_By_Expression => Ch_Expr := Get_Choice_Expression (Ch); Cond := Translate_Simple_String_Choice (Expr_Node, Chap7.Translate_Expression (Ch_Expr, Get_Type (Ch_Expr)), Val_Node, Tinfo, Func); when Iir_Kind_Choice_By_Others => 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); end case; if not First then New_Assign_Stmt (New_Obj (Cond_Var), New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); end if; Ch := Get_Chain (Ch); exit when Ch = Null_Iir; exit when not Get_Same_Alternative_Flag (Ch); exit when Get_Associated_Chain (Ch) /= Null_Iir; if First then New_Assign_Stmt (New_Obj (Cond_Var), Cond); First := False; end if; end loop; if not First then Cond := New_Obj_Value (Cond_Var); end if; Start_If_Stmt (If_Blk, Cond); 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); Func := Chap7.Find_Predefined_Function (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); 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 (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) is Expr : Iir; begin case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => New_Default_Choice (Blk); when Iir_Kind_Choice_By_Expression => Expr := Get_Choice_Expression (Choice); New_Expr_Choice (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); when Iir_Kind_Choice_By_Range => declare H, L : Iir; begin Expr := Get_Choice_Range (Choice); Get_Low_High_Limit (Expr, L, H); New_Range_Choice (Blk, Chap7.Translate_Static_Expression (L, Choice_Type), Chap7.Translate_Static_Expression (H, Choice_Type)); end; when others => Error_Kind ("translate_case_choice", Choice); end case; end Translate_Case_Choice; procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) is Expr : constant Iir := Get_Expression (Stmt); Expr_Type : constant Iir := Get_Type (Expr); begin 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 when Iir_Kind_Choice_By_Others => exit; when Iir_Kind_Choice_By_Expression => null; when others => raise Internal_Error; end case; Nbr_Choices := Nbr_Choices + 1; 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, 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; end if; end Translate_Case_Statement; procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) is F_Assoc : Iir; Value_Assoc : Iir; Value : O_Dnode; Formal_Type : Iir; Tinfo : Type_Info_Acc; Assocs : O_Assoc_List; Subprg_Info : Subprg_Info_Acc; begin F_Assoc := Param_Chain; Value_Assoc := Get_Chain (Param_Chain); Formal_Type := Get_Type (Get_Formal (Value_Assoc)); Tinfo := Get_Info (Formal_Type); case Tinfo.Type_Mode is when Type_Mode_Scalar => Open_Temp; Start_Association (Assocs, Ghdl_Write_Scalar); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); -- compute the value. Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (Value), Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); New_Association (Assocs, New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); -- length. New_Association (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), Ghdl_Index_Type))); -- call a predefined procedure New_Procedure_Call (Assocs); Close_Temp; when Type_Mode_Array | Type_Mode_Record | Type_Mode_Fat_Array => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); New_Procedure_Call (Assocs); when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Write_Procedure_Call; procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) is F_Assoc : Iir; Value_Assoc : Iir; Value : Mnode; Formal_Type : Iir; Tinfo : Type_Info_Acc; Assocs : O_Assoc_List; Subprg_Info : Subprg_Info_Acc; begin F_Assoc := Param_Chain; Value_Assoc := Get_Chain (Param_Chain); Formal_Type := Get_Type (Get_Formal (Value_Assoc)); Tinfo := Get_Info (Formal_Type); case Tinfo.Type_Mode is when Type_Mode_Scalar => Open_Temp; Start_Association (Assocs, Ghdl_Read_Scalar); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); -- value Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); New_Association (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); -- length. New_Association (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), Ghdl_Index_Type))); -- call a predefined procedure New_Procedure_Call (Assocs); Close_Temp; when Type_Mode_Array | Type_Mode_Record => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc))); New_Procedure_Call (Assocs); when Type_Mode_Fat_Array => declare Length_Assoc : Iir; Length : Mnode; begin Length_Assoc := Get_Chain (Value_Assoc); Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); end; when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Read_Procedure_Call; procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) is Imp : constant Iir := Get_Implementation (Call); Kind : constant Iir_Predefined_Functions := Get_Implicit_Definition (Imp); Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); begin case Kind is when Iir_Predefined_Write => -- Check wether text or not. declare File_Param : Iir; Assocs : O_Assoc_List; begin File_Param := Param_Chain; -- FIXME: do the test. if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) then -- If text: Start_Association (Assocs, Ghdl_Text_Write); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (File_Param))); -- compute string parameter (get a fat array pointer) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Get_Chain (Param_Chain)), String_Type_Definition)); -- call a predefined procedure New_Procedure_Call (Assocs); else Translate_Write_Procedure_Call (Imp, Param_Chain); end if; end; when Iir_Predefined_Read_Length => -- FIXME: works only for text read length. declare File_Param : Iir; N_Param : Iir; Assocs : O_Assoc_List; Str : O_Enode; Res : Mnode; begin File_Param := Param_Chain; if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) then N_Param := Get_Chain (File_Param); Str := Chap7.Translate_Expression (Get_Actual (N_Param), String_Type_Definition); N_Param := Get_Chain (N_Param); Res := Chap6.Translate_Name (Get_Actual (N_Param)); Start_Association (Assocs, Ghdl_Text_Read_Length); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (File_Param))); -- compute string parameter (get a fat array pointer) New_Association (Assocs, Str); -- call a predefined procedure New_Assign_Stmt (M2Lv (Res), New_Function_Call (Assocs)); else Translate_Read_Procedure_Call (Imp, Param_Chain); end if; end; when Iir_Predefined_Read => Translate_Read_Procedure_Call (Imp, Param_Chain); when Iir_Predefined_Deallocate => Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); when Iir_Predefined_File_Open => declare N_Param : Iir; File_Param : Iir; Name_Param : Iir; Kind_Param : Iir; Constr : O_Assoc_List; begin File_Param := Get_Actual (Param_Chain); N_Param := Get_Chain (Param_Chain); Name_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Kind_Param := Get_Actual (N_Param); if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Open); else Start_Association (Constr, Ghdl_File_Open); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Association (Constr, New_Convert_Ov (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); New_Association (Constr, Chap7.Translate_Expression (Name_Param, String_Type_Definition)); New_Procedure_Call (Constr); end; when Iir_Predefined_File_Open_Status => declare Std_File_Open_Status_Otype : constant O_Tnode := Get_Ortho_Type (File_Open_Status_Type_Definition, Mode_Value); N_Param : Iir; Status_Param : constant Iir := Get_Actual (Param_Chain); File_Param : Iir; Name_Param : Iir; Kind_Param : Iir; Constr : O_Assoc_List; Status : Mnode; begin Status := Chap6.Translate_Name (Status_Param); N_Param := Get_Chain (Param_Chain); File_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Name_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Kind_Param := Get_Actual (N_Param); if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Open_Status); else Start_Association (Constr, Ghdl_File_Open_Status); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Association (Constr, New_Convert_Ov (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); New_Association (Constr, Chap7.Translate_Expression (Name_Param, String_Type_Definition)); New_Assign_Stmt (M2Lv (Status), New_Convert_Ov (New_Function_Call (Constr), Std_File_Open_Status_Otype)); end; when Iir_Predefined_File_Close => declare File_Param : constant Iir := Get_Actual (Param_Chain); Constr : O_Assoc_List; begin if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Close); else Start_Association (Constr, Ghdl_File_Close); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Procedure_Call (Constr); end; when Iir_Predefined_Flush => declare File_Param : constant Iir := Get_Actual (Param_Chain); Constr : O_Assoc_List; begin Start_Association (Constr, Ghdl_File_Flush); New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Procedure_Call (Constr); end; when others => Ada.Text_IO.Put_Line ("translate_implicit_procedure_call: cannot handle " & Iir_Predefined_Functions'Image (Kind)); raise Internal_Error; 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 if Conv = Null_Iir then return Src; -- case Get_Type_Info (Dest).Type_Mode is -- when Type_Mode_Thin => -- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); -- when Type_Mode_Fat_Acc => -- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); -- when others => -- raise Internal_Error; -- end case; else case Get_Kind (Conv) is when Iir_Kind_Function_Call => -- Call conversion function. declare Imp : constant Iir := Get_Implementation (Conv); Conv_Info : constant Subprg_Info_Acc := Get_Info (Imp); Constr : O_Assoc_List; Res_Otype : Type_Info_Acc; Res : O_Dnode; begin Start_Association (Constr, Conv_Info.Ortho_Func); if Conv_Info.Res_Interface /= O_Dnode_Null then Res_Otype := Get_Info (Get_Return_Type (Imp)); Res := Create_Temp (Res_Otype.Ortho_Type (Mode_Value)); -- Composite result. New_Association (Constr, New_Address (New_Obj (Res), Res_Otype.Ortho_Ptr_Type (Mode_Value))); end if; Subprgs.Add_Subprg_Instance_Assoc (Constr, Conv_Info.Subprg_Instance); New_Association (Constr, Src); if Conv_Info.Res_Interface /= O_Dnode_Null then -- Composite result. New_Procedure_Call (Constr); return New_Address (New_Obj (Res), Res_Otype.Ortho_Ptr_Type (Mode_Value)); else return New_Function_Call (Constr); end if; end; when Iir_Kind_Type_Conversion => return Chap7.Translate_Type_Conversion (Src, Get_Type (Expr), Get_Type (Conv), Null_Iir); when others => Error_Kind ("do_conversion", Conv); end case; end if; end Do_Conversion; -- Translate the formal name FORMAL_NAME of an individual association but -- replace the interface name by INTER_VAR. FORMAL_INFO is the info of -- the interface. This is used to access to a sub-element of the variable -- representing the whole actual. function Translate_Individual_Association_Formal (Formal_Name : Iir; Formal_Info : Ortho_Info_Acc; Inter_Var : Mnode) return Mnode is Prev_Node : O_Dnode; Prev_Field : O_Fnode; Res : Mnode; begin -- Change the formal variable so that it is the local variable -- that will be passed to the subprogram. Prev_Node := Formal_Info.Interface_Node; Prev_Field := Formal_Info.Interface_Field; -- We need a pointer since the interface is by reference. Formal_Info.Interface_Node := M2Dp (Inter_Var); Formal_Info.Interface_Field := O_Fnode_Null; Res := Chap6.Translate_Name (Formal_Name); Formal_Info.Interface_Node := Prev_Node; Formal_Info.Interface_Field := Prev_Field; return Res; end Translate_Individual_Association_Formal; 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 := Iir_Chains.Get_Chain_Length (Assoc_Chain); -- References to the formals (for copy-out), and variables for whole -- actual of individual associations. Params : Mnode_Array (0 .. Nbr_Assoc - 1); -- The values of actuals. E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); -- Only for inout/out variables passed by copy of foreign procedures: -- the copy of the scalar. Inout_Params : Mnode_Array (0 .. Nbr_Assoc - 1); Params_Var : Var_Type; Res : Mnode; El : Iir; Pos : Natural; Constr : O_Assoc_List; Last_Individual : Natural; 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 Create_Temp_Stack2_Mark; end if; if Is_Function and then Info.Res_Interface /= O_Dnode_Null then -- Composite result. -- If we need to allocate, do it before starting the call! declare Res_Type : constant Iir := Get_Return_Type (Imp); Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); begin Res := Create_Temp (Res_Info); if Res_Info.Type_Mode /= Type_Mode_Fat_Array then Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res); end if; end; end if; 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 -- 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 -- they can add declarations. -- Non-composite in-out parameters address are saved in order to -- be able to assignate the result. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop Params (Pos) := Mnode_Null; E_Params (Pos) := O_Enode_Null; Inout_Params (Pos) := Mnode_Null; 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; 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; 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 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 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 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; 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; 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; 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 -- Composite result. New_Association (Constr, M2E (Res)); end if; if Params_Var /= Null_Var then -- Parameters record (for procedures). New_Association (Constr, New_Address (Get_Var (Params_Var), Info.Subprg_Params_Ptr)); end if; if Obj /= Null_Iir then -- Protected object. New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); else -- Instance. Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); end if; -- Parameters. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop 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; 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; end loop; -- Subprogram call. if Is_Procedure then New_Procedure_Call (Constr); else if Info.Res_Interface /= O_Dnode_Null then -- Composite result. New_Procedure_Call (Constr); return M2E (Res); else return New_Function_Call (Constr); 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 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; 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); Obj : constant Iir := Get_Method_Object (Stmt); Res : O_Enode; begin Res := Translate_Subprogram_Call (Stmt, Assoc_Chain, Obj); pragma Assert (Res = O_Enode_Null); end Translate_Procedure_Call; procedure Translate_Wait_Statement (Stmt : Iir) is Cond : constant Iir := Get_Condition_Clause (Stmt); 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 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 then if Timeout = Null_Iir then -- Process exit. Start_Association (Constr, Ghdl_Process_Wait_Exit); 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; -- Evaluate the timeout (if any) and register it, if Timeout /= Null_Iir then Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); New_Association (Constr, Chap7.Translate_Expression (Timeout, Time_Type_Definition)); New_Procedure_Call (Constr); end if; -- Evaluate the sensitivity list and register it. if Sensitivity /= Null_Iir_List then Register_Signal_List (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); 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 State_Suspend (Resume_State); else declare Eval_State : State_Type; If_Blk1, If_Blk2 : O_If_Block; begin 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; 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 if; Finish_If_Stmt (If_Blk1); end; end if; -- RESUME_STATE: -- wait_close; State_Start (Resume_State); Start_Association (Constr, Ghdl_Process_Wait_Close); New_Procedure_Call (Constr); end Translate_Wait_Statement; -- Signal assignment. Signal_Assign_Line : Natural; procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Simple_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Simple_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Simple_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Simple_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Simple_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Simple_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_assign_non_composite", Targ_Type); end case; if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; Val2 : O_Dnode; Targ2 : O_Dnode; begin Open_Temp; Val2 := Create_Temp_Init (Type_Info.Ortho_Type (Mode_Value), Val); Targ2 := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); New_Association (Assoc, New_Obj_Value (Targ2)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Targ2)); New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Convert_Ov (Val, Conv)); New_Procedure_Call (Assoc); end if; end Gen_Simple_Signal_Assign_Non_Composite; procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite (Data_Type => O_Enode, Composite_Data_Type => Mnode, Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, Update_Data_Array => Gen_Oenode_Update_Data_Array, Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, Update_Data_Record => Gen_Oenode_Update_Data_Record, Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); type Signal_Assign_Data is record Expr : Mnode; Reject : O_Dnode; After : O_Dnode; end record; procedure Gen_Start_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin if Data.Expr = Mnode_Null then -- Null transaction. Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); return; end if; Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Start_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Start_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Start_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Start_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Start_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Start_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_assign_non_composite", Targ_Type); end case; -- Check range. if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; V : Mnode; Starg : O_Dnode; begin Open_Temp; V := Stabilize_Value (Data.Expr); Starg := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Obj_Value (Data.After)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); end if; end Gen_Start_Signal_Assign_Non_Composite; function Gen_Signal_Prepare_Data_Composite (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) return Signal_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Val; end Gen_Signal_Prepare_Data_Composite; function Gen_Signal_Prepare_Data_Record (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) return Signal_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin if Val.Expr = Mnode_Null then return Val; else return Signal_Assign_Data' (Expr => Stabilize (Val.Expr), Reject => Val.Reject, After => Val.After); end if; end Gen_Signal_Prepare_Data_Record; function Gen_Signal_Update_Data_Array (Val : Signal_Assign_Data; Targ_Type : Iir; Index : O_Dnode) return Signal_Assign_Data is Res : Signal_Assign_Data; begin if Val.Expr = Mnode_Null then -- Handle null transaction. return Val; end if; Res := Signal_Assign_Data' (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), Targ_Type, New_Obj_Value (Index)), Reject => Val.Reject, After => Val.After); return Res; end Gen_Signal_Update_Data_Array; function Gen_Signal_Update_Data_Record (Val : Signal_Assign_Data; Targ_Type : Iir; El : Iir_Element_Declaration) return Signal_Assign_Data is pragma Unreferenced (Targ_Type); Res : Signal_Assign_Data; begin if Val.Expr = Mnode_Null then -- Handle null transaction. return Val; end if; Res := Signal_Assign_Data' (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), Reject => Val.Reject, After => Val.After); return Res; end Gen_Signal_Update_Data_Record; procedure Gen_Signal_Finish_Data_Composite (Data : in out Signal_Assign_Data) is pragma Unreferenced (Data); begin null; end Gen_Signal_Finish_Data_Composite; procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite (Data_Type => Signal_Assign_Data, Composite_Data_Type => Signal_Assign_Data, Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Update_Data_Array, Finish_Data_Array => Gen_Signal_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record, Finish_Data_Record => Gen_Signal_Finish_Data_Composite); procedure Gen_Next_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin if Data.Expr = Mnode_Null then -- Null transaction. Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); return; end if; Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Next_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Next_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Next_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Next_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Next_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Next_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); end case; if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; V : Mnode; Starg : O_Dnode; begin Open_Temp; V := Stabilize_Value (Data.Expr); Starg := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.After)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); end if; end Gen_Next_Signal_Assign_Non_Composite; procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite (Data_Type => Signal_Assign_Data, Composite_Data_Type => Signal_Assign_Data, Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Update_Data_Array, Finish_Data_Array => Gen_Signal_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record, Finish_Data_Record => Gen_Signal_Finish_Data_Composite); procedure Translate_Signal_Target_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir); procedure Translate_Signal_Target_Array_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir; Idx : O_Dnode; Dim : Natural) is Index_List : constant Iir_List := Get_Index_Subtype_List (Target_Type); Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); Sub_Aggr : Mnode; El : Iir; Expr : Iir; begin El := Get_Association_Choices_Chain (Target); while El /= Null_Iir loop case Get_Kind (El) is when Iir_Kind_Choice_By_None => Sub_Aggr := Chap3.Index_Base (Aggr, Target_Type, New_Obj_Value (Idx)); when others => Error_Kind ("translate_signal_target_array_aggr", El); end case; Expr := Get_Associated_Expr (El); if Dim = Nbr_Dim then Translate_Signal_Target_Aggr (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); if Get_Kind (El) = Iir_Kind_Choice_By_None then Inc_Var (Idx); else raise Internal_Error; end if; else Translate_Signal_Target_Array_Aggr (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); end if; El := Get_Chain (El); end loop; end Translate_Signal_Target_Array_Aggr; procedure Translate_Signal_Target_Record_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir) is Aggr_El : Iir; El_List : Iir_List; El_Index : Natural; Element : Iir_Element_Declaration; begin El_List := Get_Elements_Declaration_List (Get_Base_Type (Target_Type)); El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Target); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => Element := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Element := Get_Choice_Name (Aggr_El); El_Index := Natural'Last; when others => Error_Kind ("translate_signal_target_record_aggr", Aggr_El); end case; Translate_Signal_Target_Aggr (Chap6.Translate_Selected_Element (Aggr, Element), Get_Associated_Expr (Aggr_El), Get_Type (Element)); Aggr_El := Get_Chain (Aggr_El); end loop; end Translate_Signal_Target_Record_Aggr; procedure Translate_Signal_Target_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir) is Src : Mnode; begin if Get_Kind (Target) = Iir_Kind_Aggregate then declare Idx : O_Dnode; St_Aggr : Mnode; begin Open_Temp; St_Aggr := Stabilize (Aggr); case Get_Kind (Target_Type) is when Iir_Kinds_Array_Type_Definition => Idx := Create_Temp (Ghdl_Index_Type); Init_Var (Idx); Translate_Signal_Target_Array_Aggr (St_Aggr, Target, Target_Type, Idx, 1); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => Translate_Signal_Target_Record_Aggr (St_Aggr, Target, Target_Type); when others => Error_Kind ("translate_signal_target_aggr", Target_Type); end case; Close_Temp; end; else Src := Chap6.Translate_Name (Target); Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); end if; end Translate_Signal_Target_Aggr; type Signal_Direct_Assign_Data is record -- The driver Drv : Mnode; -- The value Expr : Mnode; -- The node for the expression (used to locate errors). Expr_Node : Iir; end record; procedure Gen_Signal_Direct_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) is Targ_Sig : Mnode; If_Blk : O_If_Block; Constr : O_Assoc_List; Cond : O_Dnode; Drv : Mnode; begin Open_Temp; Targ_Sig := Stabilize (Targ, True); Cond := Create_Temp (Ghdl_Bool_Type); Drv := Stabilize (Data.Drv, False); -- Set driver. Chap7.Translate_Assign (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); -- Test if the signal is active. Start_If_Stmt (If_Blk, New_Value (Chap14.Get_Signal_Field (Targ_Sig, Ghdl_Signal_Has_Active_Field))); -- Either because has_active is true. New_Assign_Stmt (New_Obj (Cond), New_Lit (Ghdl_Bool_True_Node)); New_Else_Stmt (If_Blk); -- Or because the value is different from the current driving value. -- FIXME: ideally, we should compare the value with the current -- value of the driver. This is an approximation that might break -- with weird resolution functions. New_Assign_Stmt (New_Obj (Cond), New_Compare_Op (ON_Neq, Chap7.Translate_Signal_Driving_Value (M2E (Targ_Sig), Targ_Type), M2E (Drv), Ghdl_Bool_Type)); Finish_If_Stmt (If_Blk); -- Put signal into active list (if not already in the list). -- FIXME: this is not thread-safe! Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); Start_Association (Constr, Ghdl_Signal_Direct_Assign); New_Association (Constr, New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), Ghdl_Signal_Ptr)); New_Procedure_Call (Constr); Finish_If_Stmt (If_Blk); Close_Temp; end Gen_Signal_Direct_Assign_Non_Composite; function Gen_Signal_Direct_Prepare_Data_Composite (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Val; end Gen_Signal_Direct_Prepare_Data_Composite; function Gen_Signal_Direct_Prepare_Data_Record (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Signal_Direct_Assign_Data' (Drv => Stabilize (Val.Drv), Expr => Stabilize (Val.Expr), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Prepare_Data_Record; function Gen_Signal_Direct_Update_Data_Array (Val : Signal_Direct_Assign_Data; Targ_Type : Iir; Index : O_Dnode) return Signal_Direct_Assign_Data is begin return Signal_Direct_Assign_Data' (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), Targ_Type, New_Obj_Value (Index)), Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), Targ_Type, New_Obj_Value (Index)), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Update_Data_Array; function Gen_Signal_Direct_Update_Data_Record (Val : Signal_Direct_Assign_Data; Targ_Type : Iir; El : Iir_Element_Declaration) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ_Type); begin return Signal_Direct_Assign_Data' (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), Expr => Chap6.Translate_Selected_Element (Val.Expr, El), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Update_Data_Record; procedure Gen_Signal_Direct_Finish_Data_Composite (Data : in out Signal_Direct_Assign_Data) is pragma Unreferenced (Data); begin null; end Gen_Signal_Direct_Finish_Data_Composite; procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite (Data_Type => Signal_Direct_Assign_Data, Composite_Data_Type => Signal_Direct_Assign_Data, Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) is Target : constant Iir := Get_Target (Stmt); Target_Type : constant Iir := Get_Type (Target); Arg : Signal_Direct_Assign_Data; Targ_Sig : Mnode; begin Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), Get_Info (Target_Type), Mode_Value); Arg.Expr_Node := We; Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); Chap9.Destroy_Types (Target); end Translate_Direct_Signal_Assignment; procedure Translate_Signal_Assignment_Statement (Stmt : Iir) is Target : constant Iir := Get_Target (Stmt); Target_Type : constant Iir := Get_Type (Target); We : Iir_Waveform_Element; Targ : Mnode; Val : O_Enode; Value : Iir; Is_Simple : Boolean; begin We := Get_Waveform_Chain (Stmt); if We /= Null_Iir and then Get_Chain (We) = Null_Iir and then Get_Time (We) = Null_Iir and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay and then Get_Reject_Time_Expression (Stmt) = Null_Iir then -- Simple signal assignment ? Value := Get_We_Value (We); Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; else Is_Simple := False; end if; if Get_Kind (Target) = Iir_Kind_Aggregate then Chap3.Translate_Anonymous_Type_Definition (Target_Type); Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); Translate_Signal_Target_Aggr (Targ, Target, Target_Type); else if Is_Simple and then Flag_Direct_Drivers and then Chap4.Has_Direct_Driver (Target) then Translate_Direct_Signal_Assignment (Stmt, Value); return; end if; Targ := Chap6.Translate_Name (Target); pragma Assert (Get_Object_Kind (Targ) = Mode_Signal); end if; if We = Null_Iir then -- Implicit disconnect statment. Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); Chap9.Destroy_Types (Target); return; end if; -- Handle a simple and common case: only one waveform, inertial, -- and no time (eg: sig <= expr). Value := Get_We_Value (We); Signal_Assign_Line := Get_Line_Number (Value); if Get_Chain (We) = Null_Iir and then Get_Time (We) = Null_Iir and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay and then Get_Reject_Time_Expression (Stmt) = Null_Iir and then Get_Kind (Value) /= Iir_Kind_Null_Literal then Val := Chap7.Translate_Expression (Value, Target_Type); Gen_Simple_Signal_Assign (Targ, Target_Type, Val); Chap9.Destroy_Types (Target); return; end if; -- General case. declare Var_Targ : Mnode; Targ_Tinfo : Type_Info_Acc; begin Open_Temp; Targ_Tinfo := Get_Info (Target_Type); Var_Targ := Stabilize (Targ, True); -- Translate the first waveform element. declare Reject_Time : O_Dnode; After_Time : O_Dnode; Del : Iir; Rej : Iir; Val : Mnode; Data : Signal_Assign_Data; begin Open_Temp; Reject_Time := Create_Temp (Std_Time_Otype); After_Time := Create_Temp (Std_Time_Otype); Del := Get_Time (We); if Del = Null_Iir then New_Assign_Stmt (New_Obj (After_Time), New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); else New_Assign_Stmt (New_Obj (After_Time), Chap7.Translate_Expression (Del, Time_Type_Definition)); end if; case Get_Delay_Mechanism (Stmt) is when Iir_Transport_Delay => New_Assign_Stmt (New_Obj (Reject_Time), New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); when Iir_Inertial_Delay => Rej := Get_Reject_Time_Expression (Stmt); if Rej = Null_Iir then New_Assign_Stmt (New_Obj (Reject_Time), New_Obj_Value (After_Time)); else New_Assign_Stmt (New_Obj (Reject_Time), Chap7.Translate_Expression (Rej, Time_Type_Definition)); end if; end case; if Get_Kind (Value) = Iir_Kind_Null_Literal then Val := Mnode_Null; else Val := E2M (Chap7.Translate_Expression (Value, Target_Type), Targ_Tinfo, Mode_Value); Val := Stabilize (Val); end if; Data := Signal_Assign_Data'(Expr => Val, Reject => Reject_Time, After => After_Time); Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); Close_Temp; end; -- Translate other waveform elements. We := Get_Chain (We); while We /= Null_Iir loop declare After_Time : O_Dnode; Val : Mnode; Data : Signal_Assign_Data; begin Open_Temp; After_Time := Create_Temp (Std_Time_Otype); New_Assign_Stmt (New_Obj (After_Time), Chap7.Translate_Expression (Get_Time (We), Time_Type_Definition)); Value := Get_We_Value (We); Signal_Assign_Line := Get_Line_Number (Value); if Get_Kind (Value) = Iir_Kind_Null_Literal then Val := Mnode_Null; else Val := E2M (Chap7.Translate_Expression (Value, Target_Type), Targ_Tinfo, Mode_Value); end if; Data := Signal_Assign_Data'(Expr => Val, Reject => O_Dnode_Null, After => After_Time); Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); Close_Temp; end; We := Get_Chain (We); end loop; Close_Temp; end; Chap9.Destroy_Types (Target); end Translate_Signal_Assignment_Statement; procedure Translate_Statement (Stmt : Iir) is begin New_Debug_Line_Stmt (Get_Line_Number (Stmt)); Open_Temp; case Get_Kind (Stmt) is when Iir_Kind_Return_Statement => Translate_Return_Statement (Stmt); when Iir_Kind_If_Statement => Translate_If_Statement (Stmt); when Iir_Kind_Assertion_Statement => Translate_Assertion_Statement (Stmt); when Iir_Kind_Report_Statement => Translate_Report_Statement (Stmt); when Iir_Kind_Case_Statement => Translate_Case_Statement (Stmt); when Iir_Kind_For_Loop_Statement => Translate_For_Loop_Statement (Stmt); when Iir_Kind_While_Loop_Statement => Translate_While_Loop_Statement (Stmt); when Iir_Kind_Next_Statement | Iir_Kind_Exit_Statement => Translate_Exit_Next_Statement (Stmt); when Iir_Kind_Signal_Assignment_Statement => Translate_Signal_Assignment_Statement (Stmt); when Iir_Kind_Variable_Assignment_Statement => Translate_Variable_Assignment_Statement (Stmt); when Iir_Kind_Null_Statement => -- A null statement is translated to a NOP, so that the -- statement generates code (and a breakpoint can be set on -- it). -- Emit_Nop; null; when Iir_Kind_Procedure_Call_Statement => declare Call : constant Iir := Get_Procedure_Call (Stmt); Imp : constant Iir := Get_Implementation (Call); begin 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 Translate_Procedure_Call (Call); end if; end; when Iir_Kind_Wait_Statement => Translate_Wait_Statement (Stmt); when others => Error_Kind ("translate_statement", Stmt); end case; Close_Temp; end Translate_Statement; procedure Translate_Statements_Chain (First : Iir) is Stmt : Iir; begin Stmt := First; while Stmt /= Null_Iir loop Translate_Statement (Stmt); Stmt := Get_Chain (Stmt); end loop; end Translate_Statements_Chain; function Translate_Statements_Chain_Has_Return (First : Iir) return Boolean is Stmt : Iir; Has_Return : Boolean := False; begin Stmt := First; while Stmt /= Null_Iir loop Translate_Statement (Stmt); if Get_Kind (Stmt) = Iir_Kind_Return_Statement then Has_Return := True; end if; Stmt := Get_Chain (Stmt); end loop; return Has_Return; end Translate_Statements_Chain_Has_Return; end Trans.Chap8;