-- 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 Simple_IO; with Std_Names; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Nodes_Utils; with Vhdl.Canon; with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; use Vhdl.Std_Package; with Vhdl.Utils; use Vhdl.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_Unbounded_Array | Type_Mode_Unbounded_Record => -- * 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 (Chap7.Translate_Expression (Expr, Ret_Type)); Chap3.Translate_Object_Allocation (Area, Alloc_Return, Ret_Type, Chap3.Get_Composite_Bounds (Val)); Chap3.Translate_Object_Copy (Area, Val, Ret_Type); Gen_Return; end; when Type_Mode_Bounded_Records | Type_Mode_Bounded_Arrays => -- * 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; New_Debug_Line_Stmt (Get_Line_Number (Else_Clause)); 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 (Strip_Reference_Name (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; New_Debug_Line_Stmt (Get_Line_Number (Else_Clause)); Translate_If_Statement_Direct (Else_Clause); Close_Temp; end if; end if; Finish_If_Stmt (Blk); end Translate_If_Statement_Direct; procedure Translate_If_Statement (Stmt : Iir) is begin if Get_Suspend_Flag (Stmt) then Translate_If_Statement_State (Stmt); else Translate_If_Statement_Direct (Stmt); end if; end Translate_If_Statement; -- 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 : constant Iir_Flist := Get_Enumeration_Literal_List (Base_Type); begin -- 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_Literal (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; function Is_For_Loop_Iterator_Stable (Iterator : Iir) return Boolean is Iter_Type : constant Iir := Get_Type (Iterator); Constraint : constant Iir := Get_Range_Constraint (Iter_Type); Name : Iir; begin case Iir_Kinds_Range_Attribute (Get_Kind (Constraint)) is when Iir_Kind_Reverse_Range_Array_Attribute => -- Need to create a reversed range... return False; when Iir_Kind_Range_Array_Attribute => Name := Get_Prefix (Constraint); Name := Get_Base_Name (Name); case Get_Kind (Name) is when Iir_Kind_Implicit_Dereference | Iir_Kind_Dereference => return False; when Iir_Kind_Function_Call => if not Is_Fully_Constrained_Type (Get_Type (Name)) then return False; end if; when Iir_Kinds_Object_Declaration => null; when Iir_Kind_Subtype_Declaration => null; when others => Error_Kind ("is_for_loop_iterator_stable(2)", Name); end case; return True; end case; end Is_For_Loop_Iterator_Stable; function Get_Iterator_Range_Var (Iterator : Iir) return Mnode is Iter_Type : constant Iir := Get_Type (Iterator); Iter_Type_Info : constant Type_Info_Acc := Get_Info (Get_Base_Type (Iter_Type)); It_Info : constant Ortho_Info_Acc := Get_Info (Iterator); begin if It_Info.Iterator_Range_Copy then return Lv2M (Get_Var (It_Info.Iterator_Range), Iter_Type_Info, Mode_Value, Iter_Type_Info.B.Range_Type, Iter_Type_Info.B.Range_Ptr_Type); else return Lp2M (Get_Var (It_Info.Iterator_Range), Iter_Type_Info, Mode_Value, Iter_Type_Info.B.Range_Type, Iter_Type_Info.B.Range_Ptr_Type); end if; end Get_Iterator_Range_Var; 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; Range_Type : O_Tnode; 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 -- The range must be copied if: -- * the constraint is 'range or 'reverse_range, or 'subtype, or -- 'element (ie any attribute ?) -- * the base name is a function_call returning an unbounded value, -- or a dereference. -- Note: in case of a dereference, the anonymous object can be -- deallocated within the loop. It_Info.Iterator_Range_Copy := not Is_For_Loop_Iterator_Stable (Iterator); if It_Info.Iterator_Range_Copy then Range_Type := Iter_Type_Info.B.Range_Type; else Range_Type := Iter_Type_Info.B.Range_Ptr_Type; end if; It_Info.Iterator_Range := Create_Var (Create_Var_Identifier ("IT_RANGE"), Range_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; Rng : O_Lnode; 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 Rng := Chap7.Translate_Range (Constraint, Iter_Base_Type); if It_Info.Iterator_Range_Copy then Gen_Memcpy (M2Addr (Get_Iterator_Range_Var (Iterator)), New_Address (Rng, Iter_Type_Info.B.Range_Ptr_Type), New_Lit (New_Sizeof (Iter_Type_Info.B.Range_Type, Ghdl_Index_Type))); else New_Assign_Stmt (Get_Var (It_Info.Iterator_Range), New_Address (Rng, Iter_Type_Info.B.Range_Ptr_Type)); end if; New_Assign_Stmt (Get_Var (It_Info.Iterator_Var), M2E (Chap3.Range_To_Left (Get_Iterator_Range_Var (Iterator)))); -- Before starting the loop, check whether there will be at least -- one iteration. Cond := New_Compare_Op (ON_Gt, M2E (Chap3.Range_To_Length (Get_Iterator_Range_Var (Iterator))), 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); 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 := M2E (Chap3.Range_To_Right (Get_Iterator_Range_Var (Iterator))); 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); 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, M2E (Chap3.Range_To_Dir (Get_Iterator_Range_Var (Iterator))), 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 El_List : constant Iir_Flist := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); Aggr_El : Iir; El_Index : Natural; Elem : Iir; begin 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_Named_Entity (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, Mode_Value); Chap3.Translate_Object_Copy (Targ_Node, 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 : Mnode; Temp : Mnode; begin Chap3.Translate_Anonymous_Subtype_Definition (Targ_Type, False); -- 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, Mode_Value); if Get_Kind (Expr) = Iir_Kind_Aggregate then if Get_Constraint_State (Get_Type (Expr)) /= Fully_Constrained then declare Expr_Type : constant Iir := Get_Type (Expr); Expr_Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); Val : Mnode; begin -- Create a temp. Val := Create_Temp (Expr_Tinfo); -- Set bounds from target Stabilize (Targ_Node); New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Val)), M2Addr (Chap3.Get_Composite_Bounds (Targ_Node))); -- Allocate target Chap3.Allocate_Unbounded_Composite_Base (Alloc_Stack, Val, Get_Base_Type (Expr_Type)); -- Translate aggregate Chap7.Translate_Aggregate (Val, Targ_Type, Expr); -- Assign Chap3.Translate_Object_Copy (Targ_Node, Val, Targ_Type); end; else -- In case of overlap: be sure to use an intermediate variable. declare E : Mnode; begin E := Chap7.Translate_Expression (Expr, Targ_Type); Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); end; end if; 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_Literal (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 : Operator_Info_Acc; begin New_Assign_Stmt (New_Selected_Element (New_Obj (Val_Node), Tinfo.B.Base_Field (Mode_Value)), Val); Func_Info := Get_Info (Func); Start_Association (Assoc, Func_Info.Operator_Node); Subprgs.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Operator_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. -- LEN_TYPE is the type that contains the locally static bounds. It is in -- general the type of the expression (selector) or of the first choice if -- the selector type is not locally static. procedure Translate_String_Case_Statement_Common (Stmt : Iir_Case_Statement; Choices : Iir; Len_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); Expr_Type : Iir; Base_Type : Iir; Sel_Length : Int64; Cond : O_Enode; 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); Len_Type := Expr_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.B.Bounds_Field (Mode_Value)), New_Value_Selected_Acc_Value (New_Obj (Expr_Node), Tinfo.B.Bounds_Field (Mode_Value))); -- LRM08 10.9 Case statement -- In all cases, it is an error if the value of the expression is not of -- the same length as the values of the choices. if Get_Type_Staticness (Len_Type) /= Locally and then Get_Kind (Choices) = Iir_Kind_Choice_By_Expression then Len_Type := Get_Type (Get_Choice_Expression (Choices)); pragma Assert (Get_Base_Type (Len_Type) = Base_Type); Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Len_Type)); Cond := New_Compare_Op (ON_Neq, Chap3.Get_Array_Length (Dp2M (Expr_Node, Get_Info (Expr_Type), Mode_Value), Expr_Type), New_Lit (New_Index_Lit (Unsigned_64 (Sel_Length))), Ghdl_Bool_Type); Chap6.Check_Bound_Error (Cond, Expr, 0); end if; end Translate_String_Case_Statement_Common; type Choice_Id is new Integer; 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 (Choice_Id range <>) of Choice_Info_Type; -- 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; Choices_Chain : Iir; Nbr_Choices : Positive; Choices_Info : in out Choice_Info_Arr; Handler : in out Case_Handler'Class) is First, Last : Choice_Id; El : Choice_Id; -- Selector. Tinfo : Type_Info_Acc; Expr_Node : O_Dnode; C_Node : O_Dnode; Var_Idx : O_Dnode; Others_Lit : O_Cnode; Len_Type : Iir; Choice : Iir; Has_Others : Boolean; Func : Iir; -- Number of associations. Nbr_Assocs : Natural; Sel_Length : 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, Choices_Chain, Len_Type, Tinfo, Expr_Node, C_Node); -- Generate the sorted array of choices. Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Len_Type)); String_Type := New_Constrained_Array_Type (Tinfo.B.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_Init_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, Len_Type)); El := Choices_Info (El).Choice_Chain; end loop; Finish_Array_Aggr (List, Table_Cst); Finish_Init_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_Init_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_Init_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 (Len_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.B.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; begin 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); Case_Association_Cb (Get_Associated_Chain (Choice), Handler); 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); Case_Association_Cb (Get_Associated_Chain (Choice), Handler); 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; 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; Choices : Iir; Handler : in out Case_Handler'Class) is Len_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 => Case_Association_Cb (Stmt_Chain, Handler); 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); Case_Association_Cb (Stmt_Chain, Handler); 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, Choices, Len_Type, Tinfo, Expr_Node, Val_Node); Func := Chap7.Find_Predefined_Function (Get_Base_Type (Len_Type), Iir_Predefined_Array_Equality); Cond_Var := Create_Temp (Std_Boolean_Type_Node); Translate_String_Choice (Choices); Close_Temp; 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); Expr := Get_Range_From_Discrete_Range (Expr); 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 (N : Iir; Handler : in out Case_Handler'Class) is Expr : constant Iir := Get_Expression (N); Expr_Type : constant Iir := Get_Type (Expr); Choices : Iir; begin -- Get the chain of choices. case Get_Kind (N) is when Iir_Kind_Case_Statement => Choices := Get_Case_Statement_Alternative_Chain (N); when Iir_Kind_Selected_Waveform_Assignment_Statement => Choices := Get_Selected_Waveform_Chain (N); when others => Error_Kind ("translate_case", N); end case; if Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then -- Expression is a one-dimensional array. declare Nbr_Choices : Natural := 0; Choice : Iir; begin -- Count number of choices. Choice := Choices; 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 (N, Choices, Handler); elsif Nbr_Choices <= 512 then -- Can allocate on the stack. declare subtype Valid_Choice_Id is Choice_Id range 0 .. Choice_Id (Nbr_Choices - 1); Choices_Info : Choice_Info_Arr (Valid_Choice_Id); begin Translate_String_Case_Statement_Dichotomy (N, Choices, Nbr_Choices, Choices_Info, Handler); end; else -- Allocate on the heap. declare type Choice_Info_Arr_Acc is access Choice_Info_Arr; subtype Valid_Choice_Id is Choice_Id range 0 .. Choice_Id (Nbr_Choices - 1); Choices_Info : Choice_Info_Arr_Acc; procedure Free is new Ada.Unchecked_Deallocation (Choice_Info_Arr, Choice_Info_Arr_Acc); begin Choices_Info := new Choice_Info_Arr (Valid_Choice_Id); Translate_String_Case_Statement_Dichotomy (N, Choices, Nbr_Choices, Choices_Info.all, Handler); Free (Choices_Info); end; end if; end; else -- Normal case statement: expression is discrete. declare Case_Blk : O_Case_Block; Choice : Iir; Stmt_Chain : Iir; begin Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); Choice := Choices; 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); Case_Association_Cb (Stmt_Chain, Handler); end loop; Finish_Case_Stmt (Case_Blk); end; end if; end Translate_Case; -- Handler for a case statement. type Case_Statement_Handler is new Case_Handler with record -- True if there is a suspend statement in the case statement. Has_Suspend : Boolean; -- State after the case statement. Set only if Has_Suspend is true. Next_State : State_Type; end record; procedure Case_Association_Cb (Assoc : Iir; Handler : in out Case_Statement_Handler) is Choice_State : State_Type; begin if Handler.Has_Suspend then -- Jump to the corresponding state. Choice_State := State_Allocate; State_Jump (Choice_State); else -- Execute the statements. Translate_Statements_Chain (Assoc); end if; end Case_Association_Cb; procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) is Handler : Case_Statement_Handler; begin -- Initialize handler. Handler.Has_Suspend := Get_Suspend_Flag (Stmt); if Handler.Has_Suspend then Handler.Next_State := State_Allocate; end if; -- Translate the case statement. Translate_Case (Stmt, Handler); if Handler.Has_Suspend then -- 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. declare Choice : Iir; Choice_State : State_Type; begin Choice_State := Handler.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 (Handler.Next_State); end if; Choice := Get_Chain (Choice); end loop; State_Start (Handler.Next_State); end; end if; end Translate_Case_Statement; procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) is Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); F_Assoc : constant Iir := Param_Chain; Value_Assoc : constant Iir := Get_Chain (Param_Chain); Value_Inter : constant Iir := Get_Chain (Inter_Chain); Formal_Type : constant Iir := Get_Type (Value_Inter); Tinfo : constant Type_Info_Acc := Get_Info (Formal_Type); Value : O_Dnode; Assocs : O_Assoc_List; Subprg_Info : Operator_Info_Acc; begin 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_Bounded_Arrays | Type_Mode_Bounded_Records | Type_Mode_Unbounded_Array => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Operator_Node); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Operator_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_Unbounded_Record | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Write_Procedure_Call; procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) is Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); F_Assoc : constant Iir := Param_Chain; Value_Assoc : constant Iir := Get_Chain (Param_Chain); Value_Inter : constant Iir := Get_Chain (Inter_Chain); Formal_Type : constant Iir := Get_Type (Value_Inter); Tinfo : constant Type_Info_Acc := Get_Info (Formal_Type); Value : Mnode; Assocs : O_Assoc_List; Subprg_Info : Operator_Info_Acc; begin 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), Mode_Value); 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_Bounded_Arrays | Type_Mode_Bounded_Records => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Operator_Node); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Operator_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_Unbounded_Array => declare Length_Assoc : Iir; Length : Mnode; begin Length_Assoc := Get_Chain (Value_Assoc); Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Operator_Node); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Operator_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), Mode_Value); 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_Unbounded_Record | 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); Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Call); Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); begin case Kind is when Iir_Predefined_Write => declare File_Assoc : constant Iir := Assoc_Chain; File_Param : constant Iir := Get_Actual (File_Assoc); Value_Assoc : constant Iir := Get_Chain (File_Assoc); Value_Param : constant Iir := Get_Actual (Value_Assoc); Assocs : O_Assoc_List; begin -- Check whether text or not. if Get_Text_File_Flag (Get_Type (File_Param)) then -- If text: Start_Association (Assocs, Ghdl_Text_Write); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (File_Param)); -- compute string parameter (get a fat array pointer) New_Association (Assocs, Chap7.Translate_Expression (Value_Param, String_Type_Definition)); -- call a predefined procedure New_Procedure_Call (Assocs); else Translate_Write_Procedure_Call (Imp, Assoc_Chain); end if; end; when Iir_Predefined_Read_Length => -- FIXME: works only for text read length. declare File_Assoc : constant Iir := Assoc_Chain; File_Param : constant Iir := Get_Actual (File_Assoc); N_Assoc : Iir; Assocs : O_Assoc_List; Str : O_Enode; Res : Mnode; begin if Get_Text_File_Flag (Get_Type (File_Param)) then N_Assoc := Get_Chain (File_Assoc); Str := Chap7.Translate_Expression (Get_Actual (N_Assoc), String_Type_Definition); N_Assoc := Get_Chain (N_Assoc); Res := Chap6.Translate_Name (Get_Actual (N_Assoc), Mode_Value); Start_Association (Assocs, Ghdl_Text_Read_Length); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (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, Assoc_Chain); end if; end; when Iir_Predefined_Read => Translate_Read_Procedure_Call (Imp, Assoc_Chain); when Iir_Predefined_Deallocate => Chap3.Translate_Object_Deallocation (Get_Actual (Assoc_Chain)); when Iir_Predefined_File_Open => declare File_Param : constant Iir := Get_Actual (Assoc_Chain); Name_Inter : constant Iir := Get_Chain (Inter_Chain); Name_Assoc : constant Iir := Get_Chain (Assoc_Chain); Name_Param : constant Iir := Get_Actual (Name_Assoc); Kind_Inter : constant Iir := Get_Chain (Name_Inter); Kind_Assoc : constant Iir := Get_Chain (Name_Assoc); Kind_Param : constant Iir := Get_Actual_Or_Default (Kind_Assoc, Kind_Inter); Constr : O_Assoc_List; begin 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); Status_Param : constant Iir := Get_Actual (Assoc_Chain); File_Inter : constant Iir := Get_Chain (Inter_Chain); File_Assoc : constant Iir := Get_Chain (Assoc_Chain); File_Param : constant Iir := Get_Actual (File_Assoc); Name_Inter : constant Iir := Get_Chain (File_Inter); Name_Assoc : constant Iir := Get_Chain (File_Assoc); Name_Param : constant Iir := Get_Actual (Name_Assoc); Kind_Inter : constant Iir := Get_Chain (Name_Inter); Kind_Assoc : constant Iir := Get_Chain (Name_Assoc); Kind_Param : constant Iir := Get_Actual_Or_Default (Kind_Assoc, Kind_Inter); Constr : O_Assoc_List; Status : Mnode; begin Status := Chap6.Translate_Name (Status_Param, Mode_Value); 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 (Assoc_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 (Assoc_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 => Simple_IO.Put_Line_Err ("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, Inter : Iir; Num : Natural; begin Push_Instance_Factory (Info.Call_State_Scope'Access); -- Variable for the frame. Info.Call_Params_Var := Create_Var (Create_Var_Identifier ("PARAMS"), 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); Inter := Get_Interface_Declaration_Chain (Imp); Num := 0; while Assoc /= Null_Iir loop declare Formal : constant Iir := Get_Association_Formal (Assoc, Inter); Ftype : constant Iir := Get_Type (Formal); Ftype_Info : constant Type_Info_Acc := Get_Info (Ftype); Call_Assoc_Info : Call_Assoc_Info_Acc; Actual : Iir; Act_Type : Iir; 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; Vident : Var_Ident_Type; -- For unconstrained interfaces: -- * create a field for the fat pointer, unless -- - the expression is statically built function Need_Fat_Pointer_Field return Boolean is begin return not Is_Fully_Constrained_Type (Ftype) and then (Actual = Null_Iir or else not Is_Static_Construct (Actual)); end Need_Fat_Pointer_Field; -- For unconstrained interfaces: -- * create a field for the bounds, unless -- - the expression is statically built -- - 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 statically built -- - 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 Is_Static_Construct (Actual) or else (Get_Kind (Act_Type) in Iir_Kinds_Scalar_Type_And_Subtype_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 Inter := Get_Association_Interface (Assoc, Inter); 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 -- actual 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). pragma Assert (Object_Kind = Mode_Value); declare Atype_Info : constant Type_Info_Acc := Get_Info (Act_Type); Atype_Binfo : Type_Info_Acc; Ref_Type : O_Tnode; begin if Atype_Info /= null then Ref_Type := Atype_Info.Ortho_Ptr_Type (Object_Kind); else -- Type of actual was not yet translated. Possible -- only for slice. Do it manually. Atype_Binfo := Get_Info (Get_Base_Type (Act_Type)); Ref_Type := Atype_Binfo.B.Base_Ptr_Type (Object_Kind); end if; Call_Assoc_Info.Call_Assoc_Ref := Create_Var (Create_Var_Identifier (Inter, "__REF", Num), Ref_Type, O_Storage_Local); end; end if; if Has_Value_Field then for Mode in Mode_Value .. Object_Kind loop if Ftype_Info.Type_Mode in Type_Mode_Unbounded 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.B.Base_Ptr_Type (Mode); 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 (Mode); else Val_Type := Ftype_Info.Ortho_Type (Mode); end if; end if; case Mode is when Mode_Value => Vident := Create_Var_Identifier (Inter, "__VAL", Num); when Mode_Signal => Vident := Create_Var_Identifier (Inter, "__SIG", Num); end case; Call_Assoc_Info.Call_Assoc_Value (Mode) := Create_Var (Vident, Val_Type, O_Storage_Local); end loop; end if; if Has_Bounds_Field then Call_Assoc_Info.Call_Assoc_Bounds := Create_Var (Create_Var_Identifier (Inter, "__BND", Num), Ftype_Info.B.Bounds_Type, O_Storage_Local); end if; if Has_Fat_Pointer_Field then Call_Assoc_Info.Call_Assoc_Fat (Mode_Value) := Create_Var (Create_Var_Identifier (Inter, "__FATV", Num), Ftype_Info.Ortho_Type (Mode_Value)); if Object_Kind = Mode_Signal then Call_Assoc_Info.Call_Assoc_Fat (Mode_Signal) := Create_Var (Create_Var_Identifier (Inter, "__FATS", Num), Ftype_Info.Ortho_Type (Mode_Signal)); end if; end if; Num := Num + 1; elsif Formal /= Inter and then Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then -- The whole signal value is composed of parts and must be -- updated when it changes (at each cycle is a worst case -- approximation). Keep pointer to the individual value. Call_Assoc_Info := Add_Info (Assoc, Kind_Call_Assoc); Call_Assoc_Info.Call_Assoc_Value (Mode_Value) := Create_Var (Create_Var_Identifier (Inter, "__VALP", Num), Ftype_Info.Ortho_Ptr_Type (Mode_Value)); Num := Num + 1; end if; end; Next_Association_Interface (Assoc, Inter); 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.Subprg_Node); 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), Conv); 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; Mode : Object_Kind_Type) return Mnode is Prev_Decl : 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_Decl := Formal_Info.Interface_Decl (Mode); Prev_Field := Formal_Info.Interface_Field (Mode); -- We need a pointer since the interface is by reference. Formal_Info.Interface_Decl (Mode) := M2Dp (Inter_Var); Formal_Info.Interface_Field (Mode) := O_Fnode_Null; Res := Chap6.Translate_Name (Formal_Name, Mode); Formal_Info.Interface_Decl (Mode) := Prev_Decl; Formal_Info.Interface_Field (Mode) := 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); Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); 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; -- Where to allocate to store parameters (return stack for suspendable -- procedure, stack otherwise). Alloc : Allocation_Kind; type Mnode_Array is array (Natural range <>) of Mnode; type O_Enode_Array is array (Natural range <>) of O_Enode; Nbr_Assoc : constant Natural := Vhdl.Nodes_Utils.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); E_Sig_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); -- Variable containing the frame (state, parameters, local variables). -- Exists only for procedures. Params_Var : Var_Type; -- Index of the last individual association (needed because it holds -- the actual). Last_Individual : Natural; Dynamic_Individual_Assoc : Iir; Saved_Val : Mnode_Array (0 .. Nbr_Assoc - 1); Saved_Sig : Mnode_Array (0 .. Nbr_Assoc - 1); -- Individual association: assign the individual actual of -- the whole actual. procedure Trans_Individual_Assign (Assoc : Iir; Val : Mnode; Sig : Mnode) is Formal : constant Iir := Get_Formal (Assoc); Formal_Type : constant Iir := Get_Type (Formal); Base_Formal : constant Iir := Get_Interface_Of_Formal (Formal); Formal_Info : constant Interface_Info_Acc := Get_Info (Base_Formal); Formal_Object_Kind : constant Object_Kind_Type := Get_Interface_Kind (Base_Formal); Act : constant Iir := Get_Actual (Assoc); Assoc_Info : Call_Assoc_Info_Acc; Param : Mnode; begin Param := Translate_Individual_Association_Formal (Formal, Formal_Info, Params (Last_Individual), Formal_Object_Kind); if Formal_Object_Kind = Mode_Value then Chap7.Translate_Assign (Param, M2E (Val), Act, Formal_Type, Assoc); else Chap3.Translate_Object_Copy (Param, Sig, Formal_Type); if Is_Suspendable then -- Keep reference to the value to update the whole object -- at each call. Assoc_Info := Get_Info (Assoc); New_Assign_Stmt (Get_Var (Assoc_Info.Call_Assoc_Value (Mode_Value)), M2E (Val)); else -- Assign the value to the whole object, as there is -- only one call. Param := Translate_Individual_Association_Formal (Formal, Formal_Info, Params (Last_Individual), Mode_Value); Chap3.Translate_Object_Copy (Param, Val, Formal_Type); end if; end if; end Trans_Individual_Assign; -- Evaluate the actual of ASSOC/INTER (whose index is POS), do the -- actual conversion and save the result (either copy it to a variable -- or field, or just keep the value to pass it while calling the -- subprogram). procedure Trans_Actual (Assoc : Iir; Inter : Iir; Pos : Natural) is Formal : constant Iir := Get_Association_Formal (Assoc, Inter); Formal_Type : constant Iir := Get_Type (Formal); Ftype_Info : constant Type_Info_Acc := Get_Info (Formal_Type); Base_Formal : constant Iir := Get_Interface_Of_Formal (Formal); Formal_Info : constant Interface_Info_Acc := Get_Info (Base_Formal); Formal_Object_Kind : constant Object_Kind_Type := Get_Interface_Kind (Base_Formal); Assoc_Info : Call_Assoc_Info_Acc; Act : Iir; Actual_Type : Iir; In_Conv : Iir; Param : Mnode; Param_Sig : Mnode; Param_Type : Iir; Val : O_Enode; Sig : O_Enode; Mval : Mnode; Msig : Mnode; Mode : Iir_Mode; Bounds : Mnode; Next_Assoc : Iir; -- Assign PARAMS field for formal to V. procedure Assign_Params_Field (V : O_Enode; Mode : Object_Kind_Type) is Ptr : O_Lnode; begin Ptr := New_Selected_Element (Get_Var (Params_Var), Formal_Info.Interface_Field (Mode)); New_Assign_Stmt (Ptr, V); end Assign_Params_Field; 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 (Assoc); else Assoc_Info := null; end if; case Get_Kind (Assoc) is when Iir_Kind_Association_Element_Open => Act := Get_Default_Value (Base_Formal); In_Conv := Null_Iir; when Iir_Kind_Association_Element_By_Expression => Act := Get_Actual (Assoc); In_Conv := Get_Actual_Conversion (Assoc); when Iir_Kind_Association_Element_By_Individual => Actual_Type := Get_Actual_Type (Assoc); -- Save the object as it will be used by the following -- associations. Last_Individual := Pos; for Mode in Mode_Value .. Formal_Object_Kind loop -- For individual associations, create a variable -- containing the whole actual. Each individual -- association (to the same formal) will set a part of -- this variable. if Assoc_Info = null then Param := Create_Temp (Ftype_Info, Mode); else declare Param_Var : Var_Type; begin if Ftype_Info.Type_Mode in Type_Mode_Unbounded then Param_Var := Assoc_Info.Call_Assoc_Fat (Mode); else Param_Var := Assoc_Info.Call_Assoc_Value (Mode); end if; Param := Stabilize (Get_Var (Param_Var, Ftype_Info, Mode)); end; end if; if Ftype_Info.Type_Mode in Type_Mode_Unbounded then -- Create the constraints and then the object. -- FIXME: do not allocate bounds if static. if Mode = Mode_Value then if Get_Type_Staticness (Actual_Type) >= Globally then Chap3.Create_Composite_Subtype (Actual_Type); Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type); Chap3.Translate_Object_Allocation (Param, Alloc, Formal_Type, Bounds); else -- The bounds of the formal are not known (will be -- determined by the actuals). Just allocate the -- bounds. Chap3.Allocate_Unbounded_Composite_Bounds (Alloc, Param, Formal_Type); Saved_Val (Pos) := Param; pragma Assert (Dynamic_Individual_Assoc = Null_Iir); Dynamic_Individual_Assoc := Assoc; end if; else -- Use the bounds of the value for the signal. New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Param)), M2Addr (Chap3.Get_Composite_Bounds (Params (Pos)))); if Get_Type_Staticness (Actual_Type) >= Globally then -- Allocate the base (only if the bounds are -- known). Chap3.Allocate_Unbounded_Composite_Base (Alloc, Param, Formal_Type); end if; Saved_Sig (Pos) := Param; end if; else -- Create the object. Chap4.Allocate_Complex_Object (Formal_Type, Alloc, Param); end if; -- In case of signals, don't keep value, only keep -- signal (so override the value). Params (Pos) := Param; if Formal_Info.Interface_Field (Mode) /= O_Fnode_Null then -- Set the PARAMS field. Assign_Params_Field (M2E (Param), Mode); end if; end loop; goto Continue; when others => Error_Kind ("translate_procedure_call", Assoc); end case; Actual_Type := Get_Type (Act); -- For individual associations, be sure the type is translated. -- That's required for slices in case of array conversion. if Formal /= Base_Formal then Chap3.Translate_Anonymous_Subtype_Definition (Formal_Type, False); end if; -- 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); Sig := O_Enode_Null; Param_Type := Formal_Type; when Iir_Kind_Interface_Signal_Declaration => -- No conversion. Chap6.Translate_Signal_Name (Act, Param_Sig, Param); case Formal_Info.Interface_Mechanism (Mode_Value) is when Pass_By_Copy => Val := M2E (Param); when Pass_By_Address => Val := M2Addr (Param); end case; Sig := M2E (Param_Sig); when Iir_Kind_Interface_Variable_Declaration => Mode := Get_Mode (Base_Formal); Sig := O_Enode_Null; if Mode = Iir_In_Mode then Val := Chap7.Translate_Expression (Act); else Param := Chap6.Translate_Name (Act, Mode_Value); 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, Mode_Value, Act); if Sig /= O_Enode_Null then -- FIXME: convert without checking. Sig := Chap7.Translate_Implicit_Conv (Sig, Param_Type, Formal_Type, Mode_Signal, Act); end if; 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. if Dynamic_Individual_Assoc /= Null_Iir then -- With dynamic bounds. -- FIXME: only records are supported. pragma Assert (Get_Kind (Formal) = Iir_Kind_Selected_Element); -- Save the actual. Saved_Val (Pos) := E2M (Val, Ftype_Info, Mode_Value); if Formal_Object_Kind = Mode_Signal then Saved_Sig (Pos) := E2M (Sig, Ftype_Info, Mode_Signal); end if; -- If the record element is dynamic, copy the bounds. if Is_Unbounded_Type (Ftype_Info) then Stabilize (Saved_Val (Pos)); Chap3.Copy_Bounds (Chap3.Record_Bounds_To_Element_Bounds (Chap3.Get_Composite_Bounds (Params (Last_Individual)), Get_Named_Entity (Formal)), Chap3.Get_Composite_Bounds (Saved_Val (Pos)), Formal_Type); end if; -- If this is the last association for the interface: Next_Assoc := Get_Chain (Assoc); if Next_Assoc = Null_Iir or else Get_Formal (Next_Assoc) = Null_Iir or else (Get_Interface_Of_Formal (Get_Formal (Next_Assoc)) /= Base_Formal) then -- * compute the size of the object Chap3.Gen_Call_Type_Builder (Chap3.Get_Composite_Bounds (Params (Last_Individual)), Get_Type (Base_Formal), Mode_Value); if Formal_Object_Kind = Mode_Signal then Chap3.Gen_Call_Type_Builder (Chap3.Get_Composite_Bounds (Params (Last_Individual)), Get_Type (Base_Formal), Mode_Signal); end if; -- * allocate base Chap3.Allocate_Unbounded_Composite_Base (Alloc, Saved_Val (Last_Individual), Get_Type (Base_Formal)); if Formal_Object_Kind = Mode_Signal then Chap3.Allocate_Unbounded_Composite_Base (Alloc, Saved_Sig (Last_Individual), Get_Type (Base_Formal)); end if; -- * copy all elements Next_Assoc := Dynamic_Individual_Assoc; for I in Last_Individual + 1 .. Pos loop Next_Assoc := Get_Chain (Next_Assoc); if Formal_Object_Kind = Mode_Signal then Trans_Individual_Assign (Next_Assoc, Saved_Val (I), Saved_Sig (I)); else Trans_Individual_Assign (Next_Assoc, Saved_Val (I), Mnode_Null); end if; end loop; -- * clear the flag. Dynamic_Individual_Assoc := Null_Iir; end if; else -- Individual association: assign the individual actual of -- the whole actual. if Sig = O_Enode_Null then -- Arghh.. Msig := Mnode_Null; else Msig := E2M (Sig, Get_Info (Formal_Type), Mode_Signal); end if; -- Note: Ftype_Info may be null (if the formal is a slice). Trans_Individual_Assign (Assoc, E2M (Val, Get_Info (Formal_Type), Mode_Value), Msig); end if; elsif Assoc_Info /= null then -- For suspendable caller, write the actual to the state -- record. In some cases (like expressions), the value has -- to be copied (it may be the result of a computation). -- Only for whole association. pragma Assert (Base_Formal = Formal); for Mode in Mode_Value .. Formal_Object_Kind loop if Mode = Mode_Value then Mval := Stabilize (E2M (Val, Ftype_Info, Mode_Value), True); else Mval := Stabilize (E2M (Sig, Ftype_Info, Mode_Signal), True); end if; declare Fat : Mnode; Bnd : Mnode; begin if Assoc_Info.Call_Assoc_Fat (Mode) /= Null_Var then -- pragma Assert (Sig = O_Enode_Null); -- TODO -- 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. Fat := Stabilize (Get_Var (Assoc_Info.Call_Assoc_Fat (Mode), Ftype_Info, Mode)); -- Set PARAM field to the address of the FAT field. pragma Assert (Formal_Info.Interface_Field (Mode) /= O_Fnode_Null); Assign_Params_Field (M2E (Fat), Mode); if Assoc_Info.Call_Assoc_Bounds /= Null_Var then -- Copy the bounds. Bnd := Stabilize (Lv2M (Get_Var (Assoc_Info.Call_Assoc_Bounds), Ftype_Info, Mode_Value, Ftype_Info.B.Bounds_Type, Ftype_Info.B.Bounds_Ptr_Type)); Chap3.Copy_Bounds (Bnd, Chap3.Get_Composite_Bounds (Mval), Formal_Type); New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Fat)), M2Addr (Bnd)); New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Fat)), M2Addr (Chap3.Get_Composite_Base (Mval))); else -- No need to copy the bounds. Copy_Fat_Pointer (Fat, Mval); end if; end if; if Mode = Mode_Value and then Assoc_Info.Call_Assoc_Value (Mode_Value) /= Null_Var then pragma Assert (Sig = O_Enode_Null); -- TODO if Ftype_Info.Type_Mode in Type_Mode_Unbounded then pragma Assert (Assoc_Info.Call_Assoc_Fat (Mode) /= Null_Var); -- Allocate array base Param := Fat; Chap3.Allocate_Unbounded_Composite_Base (Alloc_Return, Fat, 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 (Mode_Value), Ftype_Info, Mode_Value); Stabilize (Param); Chap4.Allocate_Complex_Object (Formal_Type, Alloc_Return, Param); Assign_Params_Field (M2Addr (Param), Mode); end if; Chap3.Translate_Object_Copy (Param, Mval, Formal_Type); end if; end; end loop; if Assoc_Info.Call_Assoc_Value (Mode_Value) = Null_Var and then Assoc_Info.Call_Assoc_Fat (Mode_Value) = Null_Var then pragma Assert (Sig = O_Enode_Null); -- Not possible. -- Set the PARAMS field. Assign_Params_Field (M2E (Mval), Mode_Value); end if; elsif Formal_Info.Interface_Field (Mode_Value) /= O_Fnode_Null then Assign_Params_Field (Val, Mode_Value); if Sig /= O_Enode_Null then Assign_Params_Field (Sig, Mode_Signal); end if; elsif Inout_Params (Pos) /= Mnode_Null then -- Not for signals. pragma Assert (Sig = O_Enode_Null); Chap3.Translate_Object_Copy (Inout_Params (Pos), E2M (Val, Get_Info (Formal_Type), Mode_Value), Formal_Type); E_Params (Pos) := M2Addr (Inout_Params (Pos)); else E_Params (Pos) := Val; E_Sig_Params (Pos) := Sig; end if; << Continue >> null; end Trans_Actual; Res : Mnode; El : Iir; Inter : Iir; Pos : Natural; Constr : O_Assoc_List; 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! -- TODO: could be eliminated if the value is also returned (RVO). 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 not in Type_Mode_Unbounded 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_Params_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; Open_Local_Temp; 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; -- Set Alloc. if Does_Callee_Suspend then Alloc := Alloc_Return; else Alloc := Alloc_Stack; 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. Dynamic_Individual_Assoc := Null_Iir; El := Assoc_Chain; Inter := Inter_Chain; Pos := 0; while El /= Null_Iir loop Params (Pos) := Mnode_Null; E_Params (Pos) := O_Enode_Null; E_Sig_Params (Pos) := O_Enode_Null; Inout_Params (Pos) := Mnode_Null; Trans_Actual (El, Inter, Pos); Next_Association_Interface (El, Inter); 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); -- Update signals value in case of individual association. declare Base_Formal : Iir; Formal : Iir; Formal_Info : Interface_Info_Acc; Formal_Type : Iir; Assoc_Info : Call_Assoc_Info_Acc; Base_Param : Mnode; Param : Mnode; Val : Mnode; begin Open_Temp; El := Assoc_Chain; Inter := Inter_Chain; while El /= Null_Iir loop Base_Formal := Get_Association_Interface (El, Inter); case Get_Kind (El) is when Iir_Kind_Association_Element_By_Individual => if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration then -- Get the whole value. Formal_Info := Get_Info (Base_Formal); Base_Param := Lp2M (New_Selected_Element (Get_Var (Params_Var), Formal_Info.Interface_Field (Mode_Value)), Get_Info (Get_Type (Base_Formal)), Mode_Value); Stabilize (Base_Param); end if; when Iir_Kind_Association_Element_By_Expression => if not Get_Whole_Association_Flag (El) and then (Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration) then Formal := Strip_Denoting_Name (Get_Formal (El)); Formal_Info := Get_Info (Base_Formal); Formal_Type := Get_Type (Formal); Assoc_Info := Get_Info (El); -- Reference the individual sub-elements of the -- whole value. Param := Translate_Individual_Association_Formal (Formal, Formal_Info, Base_Param, Mode_Value); Val := Get_Varp (Assoc_Info.Call_Assoc_Value (Mode_Value), Get_Info (Formal_Type), Mode_Value); -- Update. Chap7.Translate_Assign (Param, M2E (Val), Get_Actual (El), Formal_Type, El); end if; when others => null; end case; Next_Association_Interface (El, Inter); end loop; Close_Temp; end; end if; Start_Association (Constr, Info.Subprg_Node); 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, Mode_Value))); else -- Instance. Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); end if; -- Parameters. El := Assoc_Chain; Inter := Inter_Chain; Pos := 0; while El /= Null_Iir loop declare Formal : constant Iir := Get_Association_Formal (El, Inter); Base_Formal : constant Iir := Get_Association_Interface (El, Inter); Formal_Info : constant Ortho_Info_Acc := Get_Info (Base_Formal); begin if Formal_Info.Interface_Field (Mode_Value) = 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)); if E_Sig_Params (Pos) /= O_Enode_Null then New_Association (Constr, E_Sig_Params (Pos)); end if; 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; Next_Association_Interface (El, Inter); 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; Inter := Inter_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); Base_Formal : constant Iir := Get_Association_Interface (El, Inter); Formal_Type : Iir; Ftype_Info : Type_Info_Acc; begin if Assoc_Info /= null and then (Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration) then Formal_Type := Get_Type (Get_Named_Entity (Get_Formal (El))); Ftype_Info := Get_Info (Formal_Type); pragma Assert (Get_Interface_Kind (Base_Formal) = Mode_Value); declare Param_Var : Var_Type; begin if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then Param_Var := Assoc_Info.Call_Assoc_Fat (Mode_Value); else Param_Var := Assoc_Info.Call_Assoc_Value (Mode_Value); end if; Params (Pos) := Stabilize (Get_Var (Param_Var, Ftype_Info, Mode_Value)); end; end if; end; elsif Params (Pos) /= Mnode_Null then declare Assoc_Info : constant Call_Assoc_Info_Acc := Get_Info (El); Formal : constant Iir := Get_Association_Formal (El, Inter); Base_Formal : constant Iir := Get_Interface_Of_Formal (Formal); 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), Mode_Value); elsif Inout_Params (Pos) /= Mnode_Null then Param := Inout_Params (Pos); else pragma Assert (Formal_Info.Interface_Field (Mode_Value) /= O_Fnode_Null); Ptr := New_Selected_Element (Get_Var (Params_Var), Formal_Info.Interface_Field (Mode_Value)); 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_Formal_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; -- FIXME: scalar check ? Chap7.Translate_Assign (Param, Val, Out_Expr, Actual_Type, El); end; end if; Next_Association_Interface (El, Inter); 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)); Close_Local_Temp; 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; Vhdl.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)); Assoc_Filename_Line (Constr, Get_Line_Number (Stmt)); 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)); Assoc_Filename_Line (Constr, Get_Line_Number (Stmt)); 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_Arrays => 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_Arrays => 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_Composite_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_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, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record); 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_Arrays => 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, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record); 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_Flist := Get_Index_Subtype_List (Target_Type); Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); Sub_Aggr : Mnode; Sub_Type : Iir; El : Iir; Expr : Iir; begin El := Get_Association_Choices_Chain (Target); while El /= Null_Iir loop Expr := Get_Associated_Expr (El); case Get_Kind (El) is when Iir_Kind_Choice_By_None => if Get_Element_Type_Flag (El) then Sub_Aggr := Chap3.Index_Base (Aggr, Target_Type, New_Obj_Value (Idx)); Sub_Type := Get_Element_Subtype (Target_Type); else Sub_Type := Get_Type (Expr); Sub_Aggr := Chap3.Slice_Base (Aggr, Sub_Type, New_Obj_Value (Idx)); end if; when others => Error_Kind ("translate_signal_target_array_aggr", El); end case; if Dim = Nbr_Dim then Translate_Signal_Target_Aggr (Sub_Aggr, Expr, Sub_Type); if Get_Kind (El) = Iir_Kind_Choice_By_None then if Get_Element_Type_Flag (El) then Inc_Var (Idx); else New_Assign_Stmt (New_Obj (Idx), New_Dyadic_Op (ON_Add_Ov, New_Obj_Value (Idx), Chap3.Get_Array_Length (Sub_Aggr, Sub_Type))); end if; 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 El_List : constant Iir_Flist := Get_Elements_Declaration_List (Get_Base_Type (Target_Type)); Aggr_El : Iir; El_Index : Natural; Element : Iir_Element_Declaration; begin 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_Named_Entity (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, Mode_Signal); Chap3.Translate_Object_Copy (Aggr, 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_Stabilize (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_Stabilize; function Gen_Signal_Direct_Prepare_Data_Array (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) return Signal_Direct_Assign_Data is begin if Is_Unbounded_Type (Get_Info (Targ_Type)) then return Gen_Signal_Direct_Prepare_Data_Stabilize (Targ, Targ_Type, Val); else return Val; end if; end Gen_Signal_Direct_Prepare_Data_Array; 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 => Chap6.Translate_Indexed_Name_By_Offset (Val.Drv, Targ_Type, Index), Expr => Chap6.Translate_Indexed_Name_By_Offset (Val.Expr, Targ_Type, 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_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_Array, Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Stabilize, Update_Data_Record => Gen_Signal_Direct_Update_Data_Record); procedure Translate_Waveform_Expression (Expr : Iir; Target_Type : Iir; Targ : in out Mnode; Res : out Mnode) is Expr_Type : constant Iir := Get_Type (Expr); begin if Get_Kind (Expr) = Iir_Kind_Aggregate and then Get_Constraint_State (Expr_Type) /= Fully_Constrained then declare Expr_Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); begin -- Create a temp. Res := Create_Temp (Expr_Tinfo); -- Set bounds from target Stabilize (Targ); New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Res)), M2Addr (Chap3.Get_Composite_Bounds (Targ))); -- Allocate target Chap3.Allocate_Unbounded_Composite_Base (Alloc_Stack, Res, Get_Base_Type (Expr_Type)); -- Translate aggregate Chap7.Translate_Aggregate (Res, Target_Type, Expr); end; else Res := Chap7.Translate_Expression (Expr, Target_Type); end if; end Translate_Waveform_Expression; procedure Translate_Direct_Signal_Assignment (Target : Iir; Targ : Mnode; Drv : Mnode; We : Iir) is Target_Type : constant Iir := Get_Type (Target); Target_Tinfo : constant Type_Info_Acc := Get_Info (Target_Type); Arg : Signal_Direct_Assign_Data; Val : Mnode; Stable_Targ : Mnode; begin Stable_Targ := Targ; Translate_Waveform_Expression (We, Target_Type, Stable_Targ, Val); if Is_Composite (Target_Tinfo) then Stabilize (Val); Stabilize (Stable_Targ); Chap3.Check_Composite_Match (Target_Type, Stable_Targ, Get_Type (We), Val, We); end if; Arg := (Drv => Drv, Expr => Val, Expr_Node => We); Gen_Signal_Direct_Assign (Stable_Targ, Target_Type, Arg); end Translate_Direct_Signal_Assignment; -- Return True iff signal assignment statement STMT has a delay mechanism: -- either transport or a reject delay. function Is_Reject_Signal_Assignment (Stmt : Iir) return Boolean is begin return Get_Delay_Mechanism (Stmt) /= Iir_Inertial_Delay or else Get_Reject_Time_Expression (Stmt) /= Null_Iir; end Is_Reject_Signal_Assignment; -- Return True if waveform chain WE has only one expression, ie: -- * no time expression -- * one element -- * not a null -- which corresponds to: -- ... <= EXPR function Is_Simple_Waveform (We : Iir) return Boolean is begin if We /= Null_Iir and then Get_Chain (We) = Null_Iir and then Get_Time (We) = Null_Iir then return Get_Kind (Get_We_Value (We)) /= Iir_Kind_Null_Literal; else return False; end if; end Is_Simple_Waveform; -- Valid only for single_signal_assignment. -- True iff direct assignment can be used. function Is_Direct_Signal_Assignment (Target : Iir) return Boolean is begin return Flag_Direct_Drivers and then Get_Kind (Target) /= Iir_Kind_Aggregate and then Chap4.Has_Direct_Driver (Target); end Is_Direct_Signal_Assignment; type Signal_Assignment_Mechanism is (Signal_Assignment_Direct, Signal_Assignment_Simple, Signal_Assignment_General); procedure Translate_Signal_Assignment_Target (Target : Iir; Mechanism : Signal_Assignment_Mechanism; Targ : out Mnode; Drv : out Mnode) is Target_Type : constant Iir := Get_Type (Target); Target_Tinfo : Type_Info_Acc; Bounds : Mnode; begin if Get_Kind (Target) = Iir_Kind_Aggregate then Chap3.Translate_Anonymous_Subtype_Definition (Target_Type, False); Target_Tinfo := Get_Info (Target_Type); Targ := Create_Temp (Target_Tinfo, Mode_Signal); if Target_Tinfo.Type_Mode in Type_Mode_Unbounded then Bounds := Dv2M (Create_Temp (Target_Tinfo.B.Bounds_Type), Target_Tinfo, Mode_Value, Target_Tinfo.B.Bounds_Type, Target_Tinfo.B.Bounds_Ptr_Type); New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Targ)), M2Addr (Bounds)); -- Build bounds from aggregate. Chap7.Translate_Aggregate_Bounds (Bounds, Target); Chap3.Allocate_Unbounded_Composite_Base (Alloc_Stack, Targ, Target_Type); Translate_Signal_Target_Aggr (Chap3.Get_Composite_Base (Targ), Target, Target_Type); else Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); Translate_Signal_Target_Aggr (Targ, Target, Target_Type); end if; else if Mechanism = Signal_Assignment_Direct then Chap6.Translate_Direct_Driver (Target, Targ, Drv); else Targ := Chap6.Translate_Name (Target, Mode_Signal); end if; end if; end Translate_Signal_Assignment_Target; procedure Translate_Waveform_Assignment (Stmt : Iir; Mechanism : Signal_Assignment_Mechanism; Wf_Chain : Iir; Targ : Mnode; Drv : Mnode) is Target : constant Iir := Strip_Reference_Name (Get_Target (Stmt)); Target_Type : constant Iir := Get_Type (Target); We : Iir_Waveform_Element; Value : Iir; begin if Mechanism = Signal_Assignment_Direct then Translate_Direct_Signal_Assignment (Target, Targ, Drv, Get_We_Value (Wf_Chain)); return; end if; if Wf_Chain = Null_Iir then -- Implicit disconnect statment. Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); return; end if; -- Handle a simple and common case: only one waveform, inertial, -- and no time (eg: sig <= expr). Value := Get_We_Value (Wf_Chain); Signal_Assign_Line := Get_Line_Number (Value); if Mechanism = Signal_Assignment_Simple then declare Targ_Tinfo : constant Type_Info_Acc := Get_Info (Target_Type); Val : Mnode; Targ2 : Mnode; begin Open_Temp; Targ2 := Targ; Translate_Waveform_Expression (Value, Target_Type, Targ2, Val); if Is_Composite (Targ_Tinfo) and then Get_Constraint_State (Target_Type) /= Fully_Constrained then Stabilize (Targ2); Stabilize (Val); Chap3.Check_Composite_Match (Target_Type, Targ2, Get_Type (Value), Val, Wf_Chain); end if; Gen_Simple_Signal_Assign (Targ2, Target_Type, M2E (Val)); Close_Temp; end; return; end if; -- General case. declare Targ_Tinfo : constant Type_Info_Acc := Get_Info (Target_Type); Var_Targ : Mnode; begin Open_Temp; Var_Targ := Stabilize (Targ, True); -- Translate the first waveform element. We := Wf_Chain; 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 Translate_Waveform_Expression (Value, Target_Type, Var_Targ, Val); Stabilize (Val); Chap3.Check_Composite_Match (Target_Type, Var_Targ, Get_Type (Value), Val, We); 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 := Chap7.Translate_Expression (Value, Target_Type); if Is_Composite (Targ_Tinfo) then Stabilize (Val); Chap3.Check_Composite_Match (Target_Type, Var_Targ, Get_Type (Value), Val, We); end if; 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; end Translate_Waveform_Assignment; procedure Translate_Simple_Signal_Assignment_Statement (Stmt : Iir) is Target : constant Iir := Strip_Reference_Name (Get_Target (Stmt)); Wf_Chain : constant Iir := Get_Waveform_Chain (Stmt); Mechanism : Signal_Assignment_Mechanism; Targ : Mnode; Drv : Mnode; begin if Is_Valid (Wf_Chain) and then Get_Kind (Wf_Chain) = Iir_Kind_Unaffected_Waveform then -- Unaffected, like a null statement. return; end if; if Is_Reject_Signal_Assignment (Stmt) or else not Is_Simple_Waveform (Wf_Chain) then Mechanism := Signal_Assignment_General; else if Is_Direct_Signal_Assignment (Target) then Mechanism := Signal_Assignment_Direct; else Mechanism := Signal_Assignment_Simple; end if; end if; Translate_Signal_Assignment_Target (Target, Mechanism, Targ, Drv); Translate_Waveform_Assignment (Stmt, Mechanism, Wf_Chain, Targ, Drv); Chap9.Destroy_Types (Target); end Translate_Simple_Signal_Assignment_Statement; type Selected_Assignment_Handler is new Case_Handler with record Stmt : Iir; Mechanism : Signal_Assignment_Mechanism; Targ : Mnode; Drv : Mnode; end record; procedure Case_Association_Cb (Assoc : Iir; Handler : in out Selected_Assignment_Handler) is begin Open_Temp; Translate_Waveform_Assignment (Handler.Stmt, Handler.Mechanism, Assoc, Handler.Targ, Handler.Drv); Close_Temp; end Case_Association_Cb; procedure Translate_Selected_Waveform_Assignment_Statement (Stmt : Iir) is Target : constant Iir := Get_Target (Stmt); Swf_Chain : constant Iir := Get_Selected_Waveform_Chain (Stmt); Swf : Iir; Wf : Iir; Handler : Selected_Assignment_Handler; begin Handler.Stmt := Stmt; -- Compute the mechanism used. if Is_Reject_Signal_Assignment (Stmt) then Handler.Mechanism := Signal_Assignment_General; else if Is_Direct_Signal_Assignment (Target) then Handler.Mechanism := Signal_Assignment_Direct; else Handler.Mechanism := Signal_Assignment_Simple; end if; Swf := Swf_Chain; while Swf /= Null_Iir loop Wf := Get_Associated_Chain (Swf); if Wf /= Null_Iir then if not Is_Simple_Waveform (Wf) then Handler.Mechanism := Signal_Assignment_General; exit; end if; end if; Swf := Get_Chain (Swf); end loop; end if; Open_Temp; Translate_Signal_Assignment_Target (Target, Handler.Mechanism, Handler.Targ, Handler.Drv); Handler.Targ := Stabilize (Handler.Targ, True); if Handler.Mechanism = Signal_Assignment_Direct then Handler.Drv := Stabilize (Handler.Drv, True); end if; Translate_Case (Stmt, Handler); Close_Temp; end Translate_Selected_Waveform_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_Simple_Signal_Assignment_Statement => Translate_Simple_Signal_Assignment_Statement (Stmt); when Iir_Kind_Selected_Waveform_Assignment_Statement => Translate_Selected_Waveform_Assignment_Statement (Stmt); when Iir_Kind_Variable_Assignment_Statement => Translate_Variable_Assignment_Statement (Stmt); when Iir_Kind_Conditional_Variable_Assignment_Statement => declare C_Stmt : Iir; begin C_Stmt := Vhdl.Canon.Canon_Conditional_Variable_Assignment_Statement (Stmt); Trans.Update_Node_Infos; Translate_If_Statement (C_Stmt); end; when Iir_Kind_Conditional_Signal_Assignment_Statement => declare C_Stmt : Iir; begin C_Stmt := Vhdl.Canon.Canon_Conditional_Signal_Assignment_Statement (Stmt); Trans.Update_Node_Infos; Translate_If_Statement (C_Stmt); end; 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. Vhdl.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;