----------------------------------------------- --------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_HI_ADA.ACTIVITY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, GET-Telecom Paris. -- -- -- -- Ocarina is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. Ocarina 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 distributed with Ocarina; see file COPYING. -- -- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- Ocarina is maintained by the Ocarina team -- -- (ocarina-users@listes.enst.fr) -- -- -- ------------------------------------------------------------------------------ with Namet; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components; with Ocarina.Generators.Utils; with Ocarina.Generators.Properties; with Ocarina.Generators.Messages; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Values; with Ocarina.Generators.PO_HI_Ada.Mapping; with Ocarina.Generators.PO_HI_Ada.Runtime; package body Ocarina.Generators.PO_HI_Ada.Activity is use Namet; use Ocarina.Nodes; use Ocarina.Entities.Components; use Ocarina.Generators.Utils; use Ocarina.Generators.Properties; use Ocarina.Generators.Messages; use Ocarina.Generators.Ada_Tree.Nutils; use Ocarina.Generators.Ada_Values; use Ocarina.Generators.PO_HI_Ada.Mapping; use Ocarina.Generators.PO_HI_Ada.Runtime; package AAN renames Ocarina.Nodes; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; function Send_Output_Spec (E : node_id) return node_id; function Put_Value_Spec (E : node_id) return node_id; function Receive_Input_Spec (E : node_id) return node_id; function Get_Value_Spec (E : node_id) return node_id; function Get_Count_Spec (E : node_id) return node_id; function Next_Value_Spec (E : node_id) return node_id; function Wait_For_Incoming_Events_Spec (E : node_id) return node_id; -- Runtime routines provided for each AADL thread ---------------------- -- Send_Output_Spec -- ---------------------- function Send_Output_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_send_output)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_in)), Return_Type => No_Node); return N; end Send_Output_Spec; -------------------- -- Put_Value_Spec -- -------------------- function Put_Value_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_put_value)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_thread_interface)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Interface_Name (E)), Parameter_Mode => mode_in)), Return_Type => No_Node); return N; end Put_Value_Spec; ------------------------ -- Receive_Input_Spec -- ------------------------ function Receive_Input_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_receive_input)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_in)), Return_Type => No_Node); return N; end Receive_Input_Spec; -------------------- -- Get_Value_Spec -- -------------------- function Get_Value_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_get_value)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_in)), Return_Type => Make_Defining_Identifier (Map_Port_Interface_Name (E))); return N; end Get_Value_Spec; -------------------- -- Get_Count_Spec -- -------------------- function Get_Count_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_get_count)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_in)), Return_Type => RE (re_integer)); return N; end Get_Count_Spec; --------------------- -- Next_Value_Spec -- --------------------- function Next_Value_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_next_value)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_in)), Return_Type => No_Node); return N; end Next_Value_Spec; ----------------------------------- -- Wait_For_Incoming_Events_Spec -- ----------------------------------- function Wait_For_Incoming_Events_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_wait_for_incoming_events)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Parameter_Mode => mode_out)), Return_Type => No_Node); return N; end Wait_For_Incoming_Events_Spec; ------------------ -- Package_Spec -- ------------------ package body Package_Spec is procedure Visit_Architecture_Instance (E : node_id); procedure Visit_Component_Instance (E : node_id); procedure Visit_System_Instance (E : node_id); procedure Visit_Process_Instance (E : node_id); procedure Visit_Thread_Instance (E : node_id); function Periodic_Task_Instantiation (E : node_id) return node_id; -- Build a package instantiation for a periodic task function Sporadic_Task_Instantiation (E : node_id) return node_id; -- Build a package instantiation for a sporadic task function Task_Job_Spec (E : node_id) return node_id; -- Creates the parameterless subprogram specification that does -- the thread's job. procedure Runtime_Routine_Specs (E : node_id); -- Creates the specs of all the routines provided by the runtime -- to the user-code to manipulate thread interface. function Deliver_Spec (E : node_id) return node_id; -- Create a subprogram specification corresponding to the -- message delivery subprogram. --------------------------------- -- Periodic_Task_Instantiation -- --------------------------------- function Periodic_Task_Instantiation (E : node_id) return node_id is N : node_id; Parameter_List : constant list_id := New_List (ADN.k_parameter_profile); I : unsigned_long_long; S : constant node_id := Parent_Subcomponent (E); begin -- Build the parameters list -- The entity name N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_entity)), Actual_Parameter => Make_Defining_Identifier (Map_Ada_Enumerator_Name (S))); Append_Node_To_List (N, Parameter_List); -- The task period, the thread being periodic it has -- necessarily a period. Otherwise, an error will be raised. N := Map_Ada_Time (Get_Thread_Period (E)); if No (N) then Display_Located_Error (Loc (E), "Unable to convert picoseconds period into nanoseconds", Fatal => True); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_period)), Actual_Parameter => N); Append_Node_To_List (N, Parameter_List); -- The task priority, if the thread has no priority, we -- assign a default one. I := Get_Thread_Priority (E); if I = 0 then N := RE (re_default_priority); else N := Map_Ada_Priority (I); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_priority)), Actual_Parameter => N); Append_Node_To_List (N, Parameter_List); -- The task stack size, if the thread has no stack size, we -- assign a default one. I := Map_Ada_Size (Get_Thread_Stack_Size (E)); if I = 0 then N := Make_Literal (New_Integer_Value (64_000, 1, 10)); else N := Make_Literal (New_Integer_Value (I, 1, 10)); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_stack_size)), Actual_Parameter => N); Append_Node_To_List (N, Parameter_List); -- The task job N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_job)), Actual_Parameter => Map_Task_Job_Identifier (E)); Append_Node_To_List (N, Parameter_List); -- Build the package instantiation N := Make_Package_Instantiation (Defining_Identifier => Map_Task_Identifier (E), Generic_Package => RU (ru_polyorb_hi_periodic_task), Parameter_List => Parameter_List); return N; end Periodic_Task_Instantiation; --------------------------------- -- Sporadic_Task_Instantiation -- --------------------------------- function Sporadic_Task_Instantiation (E : node_id) return node_id is N : node_id; Associations : constant list_id := New_List (ADN.k_list_id); P : node_id; Has_In_Event_Ports : Boolean := False; I : unsigned_long_long; begin -- Handle the type discriminants -- * Entity N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_entity)), Actual_Parameter => Make_Defining_Identifier (Map_Ada_Enumerator_Name (Parent_Subcomponent (E)))); Append_Node_To_List (N, Associations); -- Raise an error if the thread does not have IN ports if not Has_In_Ports (E) then Display_Located_Error (Loc (E), "This sporadic thread does not have IN ports", Fatal => True); end if; P := First_Node (Features (E)); while Present (P) loop if Kind (P) = k_port_spec_instance and then Is_In (P) and then Is_Event (P) then Has_In_Event_Ports := True; exit; end if; P := Next_Node (P); end loop; -- Display an error if the thread does not have 'in event' -- ports. if not Has_In_Event_Ports then Display_Located_Error (Loc (E), "None of the IN ports of this sporadic thread is an event port", Fatal => True); end if; -- * Task_Period -- The task inter-arrival time, the thread being sporadic it -- has necessarily an minimal interarrival time. Otherwise, -- an error will be raised. N := Map_Ada_Time (Get_Thread_Period (E)); if No (N) then Display_Located_Error (Loc (E), "Unable to convert picosecond-period into nanoseconds", Fatal => True); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_period)), Actual_Parameter => N); Append_Node_To_List (N, Associations); -- * Task_Priority -- The task priority, if the thread has no priority, we -- assign a default one. I := Get_Thread_Priority (E); if I = 0 then N := RE (re_default_priority); else N := Map_Ada_Priority (I); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_priority)), Actual_Parameter => N); Append_Node_To_List (N, Associations); -- * Task_Stack_Size -- The task stack size, if the thread has no stack size, we -- assign a default one. I := Map_Ada_Size (Get_Thread_Stack_Size (E)); if I = 0 then N := Make_Literal (New_Integer_Value (64_000, 1, 10)); else N := Make_Literal (New_Integer_Value (I, 1, 10)); end if; N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_task_stack_size)), Actual_Parameter => N); Append_Node_To_List (N, Associations); -- * Task job N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (p_job)), Actual_Parameter => Map_Task_Job_Identifier (E)); Append_Node_To_List (N, Associations); -- Build the package instantiation N := Make_Package_Instantiation (Defining_Identifier => Map_Task_Identifier (E), Generic_Package => RU (ru_polyorb_hi_sporadic_task), Parameter_List => Associations); return N; end Sporadic_Task_Instantiation; ------------------- -- Task_Job_Spec -- ------------------- function Task_Job_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Map_Task_Job_Identifier (E), Parameter_Profile => No_List); return N; end Task_Job_Spec; --------------------------- -- Runtime_Routine_Specs -- --------------------------- procedure Runtime_Routine_Specs (E : node_id) is N : node_id; begin -- Send_Output N := Send_Output_Spec (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Put_Value N := Put_Value_Spec (E); Bind_AADL_To_Put_Value (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Receive_Input N := Receive_Input_Spec (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Get_Value N := Get_Value_Spec (E); Bind_AADL_To_Get_Value (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Get_Count N := Get_Count_Spec (E); Bind_AADL_To_Get_Count (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Next_Value N := Next_Value_Spec (E); Bind_AADL_To_Next_Value (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Wait_For_Incoming_Events N := Wait_For_Incoming_Events_Spec (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end Runtime_Routine_Specs; ------------------ -- Deliver_Spec -- ------------------ function Deliver_Spec (E : node_id) return node_id is pragma unreferenced (E); Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin -- Entity N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_entity)), Subtype_Mark => RE (re_entity_type), Parameter_Mode => mode_in); Append_Node_To_List (N, Profile); -- Message N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_message)), Subtype_Mark => RE (re_stream_element_array), Parameter_Mode => mode_in); Append_Node_To_List (N, Profile); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_deliver)), Parameter_Profile => Profile, Return_Type => No_Node); return N; end Deliver_Spec; ----------- -- Visit -- ----------- procedure Visit (E : node_id) is begin case Kind (E) is when k_architecture_instance => Visit_Architecture_Instance (E); when k_component_instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : node_id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Visit_System_Instance (E); when cc_process => Visit_Process_Instance (E); when cc_thread => Visit_Thread_Instance (E); when others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is U : constant node_id := ADN.Distributed_Application_Unit (ADN.Naming_Node (Backend_Node (Identifier (E)))); P : constant node_id := ADN.Entity (U); S : node_id; N : node_id; begin Push_Entity (P); Push_Entity (U); Set_Activity_Spec; -- Make the deployment and naming packages use-visible Add_With_Package (RU (ru_deployment, False), Used => True); -- Generate a delivery spec if necessary if Need_Delivery (E) then N := Deliver_Spec (E); Bind_AADL_To_Deliver (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end if; -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- If the process has a data subcomponent, then map a -- shared variable. if Utils.Is_Data (Corresponding_Instance (S)) then N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (S), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (S))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Link the variable and the object Bind_AADL_To_Object (Identifier (S), N); else -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); end if; S := Next_Node (S); end loop; end if; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin Push_Entity (HI_Distributed_Application_Root); -- Visit all the subcomponents of the system if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- HI_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is P : constant supported_thread_dispatch_protocol := Get_Thread_Dispatch_Protocol (E); S : constant node_id := Parent_Subcomponent (E); N : node_id; begin if P = thread_periodic then N := Message_Comment ("Periodic task : " & Get_Name_String (Display_Name (Identifier (S)))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); elsif P = thread_sporadic then N := Message_Comment ("Sporadic task : " & Get_Name_String (Display_Name (Identifier (S)))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end if; -- Create the spec of the parameterless subprogram that -- executes the thread job. N := Task_Job_Spec (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); Bind_AADL_To_Job (Identifier (S), N); if Has_Ports (E) then -- Declare the enumeration type gathering all the thread -- ports. N := Map_Port_Enumeration (E); Bind_AADL_To_Port_Enumeration (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Declare the thread interface discriminated record type N := Map_Port_Interface (E); Bind_AADL_To_Port_Interface (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Declare the routines that allow user code to -- manipulate the thread. Runtime_Routine_Specs (E); end if; -- For each periodic thread, we instantiate a task. if P = thread_periodic then -- Instantiate the periodic task N := Periodic_Task_Instantiation (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); elsif P = thread_sporadic then -- Instantiate the sporadic task N := Sporadic_Task_Instantiation (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end if; end Visit_Thread_Instance; end Package_Spec; ------------------ -- Package_Body -- ------------------ package body Package_Body is procedure Visit_Architecture_Instance (E : node_id); procedure Visit_Component_Instance (E : node_id); procedure Visit_System_Instance (E : node_id); procedure Visit_Process_Instance (E : node_id); procedure Visit_Thread_Instance (E : node_id); function Task_Job_Body (E : node_id) return node_id; -- Creates the parameterless subprogram body that does the -- thread's job. procedure Runtime_Routine_Bodies (E : node_id); -- Creates the implementations of all the routines provided by -- the runtime to the user-code to manipulate thread interface. function Deliver_Body (E : node_id) return node_id; -- Create a subprogram implementation corresponding to the -- message delivery subprogram. function Internal_Delivery_Spec (E : node_id) return node_id; function Internal_Delivery_Body (E : node_id) return node_id; -- Create the internal delivery routine corresponding to the -- thread E. function Make_Modes_Enumeration (E : node_id) return node_id; function Make_Current_Mode_Declaration (E : node_id) return node_id; -- Create, if necessary, the enumeratin type and the current -- mode variable declaration for thread E. ------------------- -- Task_Job_Body -- ------------------- function Task_Job_Body (E : node_id) return node_id is S : constant node_id := Parent_Subcomponent (E); Spec : constant node_id := ADN.Job_Node (Backend_Node (Identifier (S))); Declarations : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); P : constant supported_thread_dispatch_protocol := Get_Thread_Dispatch_Protocol (E); Impl_Kind : constant supported_thread_implementation := Get_Thread_Implementation_Kind (E); function Get_Fully_Qualified_Subprogram (S : name_id) return node_id; -- Return an identifier to S whose parent unit name is the -- instantiated package correspodning to the interface of E. function Make_Get_Valid_Value (F : node_id) return node_id; -- This function generated an If statement that tests -- whether the port ever received a value. In this case, it -- returns tha last received value. Otherwithe, it return -- the default value for the port data type. -------------------------------------------------------------- -- All routines below do NOT perfom any verification on the -- -- thread and rely completely on the good faith of their -- -- caller. -- -------------------------------------------------------------- procedure Make_Wait_Event; -- Generate a blocking call to the routine that waits for -- new incoming events. procedure Make_Mode_Update; -- Generate a case statement that updates the thread mode -- depending on the received event port. The event port that -- causes the mode switch is dequeued. procedure Make_Fetch_In_Ports; -- Generate the routines to fetch the values of the thread -- IN ports in a non-blocking way. procedure Make_Dequeue_In_Ports; -- Generate the routines to dequeue the oldest values of the -- thread IN ports in a non-blocking way. procedure Make_Call_Sequence; -- Generate code relying on the thread call sequence procedure Make_Thread_Compute_Entrypoint; -- Generate code relying on the thread's own compute -- entrypoint. procedure Make_Ports_Compute_Entrypoint; -- Generate code relying on the compute entrypoints of the -- thread ports. procedure Make_Set_Out_Ports; -- Generate the routines to set the values of the thread OUT -- ports. procedure Make_Send_Out_Ports; -- Generate the routines to send the values of the thread -- OUT ports. procedure Make_Sporadic_Task_Blocking; -- Generate the delay statement at the end of the cycle of a -- sporadic task. ------------------------------------ -- Get_Fully_Qualified_Subprogram -- ------------------------------------ function Get_Fully_Qualified_Subprogram (S : name_id) return node_id is P : constant node_id := Make_Defining_Identifier (Map_Interrogators_Name (E)); N : constant node_id := Make_Defining_Identifier (S); begin Set_Homogeneous_Parent_Unit_Name (N, P); return N; end Get_Fully_Qualified_Subprogram; -------------------------- -- Make_Get_Valid_Value -- -------------------------- function Make_Get_Valid_Value (F : node_id) return node_id is Then_Statements : constant list_id := New_List (ADN.k_statement_list); Else_Statements : constant list_id := New_List (ADN.k_statement_list); Condition : node_id; N : node_id; begin -- The condition of validity is that the return value of -- Get_Count is different from -1. N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_get_count)), Make_List_Id (Map_Ada_Defining_Identifier (F))); Condition := Make_Expression (N, op_not_equal, Make_Literal (New_Integer_Value (1, -1, 10))); -- Then N := Make_Selected_Component (Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_get_value)), Make_List_Id (Map_Ada_Defining_Identifier (F))), Make_Defining_Identifier (Map_Ada_Component_Name (F))); N := Make_Assignment_Statement (Map_Ada_Defining_Identifier (F, 'V'), N); Append_Node_To_List (N, Then_Statements); -- Else N := Extract_Designator (ADN.Default_Value_Node (Backend_Node (Identifier (Corresponding_Instance (F))))); N := Make_Assignment_Statement (Map_Ada_Defining_Identifier (F, 'V'), N); Append_Node_To_List (N, Else_Statements); N := Make_If_Statement (Condition => Condition, Then_Statements => Then_Statements, Else_Statements => Else_Statements); return N; end Make_Get_Valid_Value; --------------------- -- Make_Wait_Event -- --------------------- procedure Make_Wait_Event is N : node_id; begin -- Declare the Port variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Object_Definition => Make_Defining_Identifier (Map_Port_Enumeration_Name (E))); Append_Node_To_List (N, Declarations); -- Declare the time related routines N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_period)), Object_Definition => RE (re_time_span), Constant_Present => True, Expression => Map_Ada_Time (Get_Thread_Period (E))); Append_Node_To_List (N, Declarations); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_next_start)), Object_Definition => RE (re_time)); Append_Node_To_List (N, Declarations); N := Make_Used_Type (RE (re_time)); Append_Node_To_List (N, Declarations); -- Call Wait_For_Incoming_Events N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_wait_for_incoming_events)), Make_List_Id (Make_Defining_Identifier (PN (p_port)))); Append_Node_To_List (N, Statements); -- Set the next startup time N := Make_Expression (RE (re_clock), op_plus, Make_Defining_Identifier (PN (p_period))); N := Make_Assignment_Statement (Make_Defining_Identifier (PN (p_next_start)), N); Append_Node_To_List (N, Statements); end Make_Wait_Event; ---------------------- -- Make_Mode_Update -- ---------------------- procedure Make_Mode_Update is Alternatives : constant list_id := New_List (ADN.k_list_id); Inner_Alternatives : list_id; Choices : list_id; Inner_Statements : list_id; F : node_id; N : node_id; M : node_id; Src : node_id; function Belongs (F : node_id; L : list_id) return Boolean; -- Return True IFF F is referenced by one of the entity -- reference instances of list L. ------------- -- Belongs -- ------------- function Belongs (F : node_id; L : list_id) return Boolean is Ref : node_id; begin Ref := First_Node (L); while Present (Ref) loop if F = Item (Last_Node (Path (Ref))) then return True; end if; Ref := Next_Node (Ref); end loop; return False; end Belongs; begin -- FIXME: Taking account of port urgency should NOT be -- implemented her but in the event delivery routine -- (thread interrogators). -- If the thread is sporadic, we already got the value of -- the port that triggered the thread. If the thread is -- sporadic, we read the value of the oldest triggered -- event port. if P = thread_periodic then -- Declare the Port and Valid variables N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Object_Definition => Make_Defining_Identifier (Map_Port_Enumeration_Name (E))); Append_Node_To_List (N, Declarations); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_valid)), Object_Definition => RE (re_boolean)); Append_Node_To_List (N, Declarations); -- Call Get_Next_Event N := Make_Defining_Identifier (SN (s_get_next_event)); Set_Homogeneous_Parent_Unit_Name (N, Make_Defining_Identifier (Map_Interrogators_Name (E))); N := Make_Subprogram_Call (N, Make_List_Id (Make_Defining_Identifier (PN (p_port)), Make_Defining_Identifier (PN (p_valid)))); Append_Node_To_List (N, Statements); end if; -- We generate a global case statement basing on the -- received (or read) port. Each alternative of the -- statement contains a nested case statement based on -- the current mode value to perform the switch. F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then not AAN.Is_Data (F) then M := First_Node (Mode_transitions (E)); Inner_Alternatives := New_List (ADN.k_statement_list); while Present (M) loop -- If F belongs to the port list of the mode -- transition M, generate necessary case -- alternative for the mode change. We are sure -- this works using case statements without -- having the risk of to case alternative with -- the same labels means the mode switch state -- machine is not deterministic as stated by the -- AADL standard. if Belongs (F, Unique_Ports (M)) then -- For each one of the source ports of M -- generate an inner case alternatice that -- effects the mode switch. Src := First_Node (Source_Modes (M)); Choices := New_List (ADN.k_list_id); Inner_Statements := New_List (ADN.k_statement_list); while Present (Src) loop N := Map_Ada_Defining_Identifier (Item (Src)); Append_Node_To_List (N, Choices); Src := Next_Node (Src); end loop; -- Perform the mode change N := Make_Assignment_Statement (Make_Defining_Identifier (Map_Current_Mode_Name (E)), Map_Ada_Defining_Identifier (Item (Destination_Mode (M)))); Append_Node_To_List (N, Inner_Statements); -- Dequeue the event port -- Create a qualified value of the port enumerator -- to avoid name clashing between ports N := Make_Record_Aggregate (Make_List_Id (Make_Defining_Identifier (PN (p_port)))); N := Make_Qualified_Expression (Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), N); -- Call Next_Value N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_next_value)), Make_List_Id (N)); Append_Node_To_List (N, Inner_Statements); N := Make_Case_Statement_Alternative (Choices, Inner_Statements); Append_Node_To_List (N, Inner_Alternatives); end if; M := Next_Node (M); end loop; -- If the port triggers at least one mode switch, -- add a case alternative if not Is_Empty (Inner_Alternatives) then -- Default case alternative (when others => null;) N := Make_Case_Statement_Alternative (No_List, No_List); Append_Node_To_List (N, Inner_Alternatives); N := Make_Case_Statement (Make_Defining_Identifier (Map_Current_Mode_Name (E)), Inner_Alternatives); -- External case alternative N := Make_Case_Statement_Alternative (Make_List_Id (Map_Ada_Defining_Identifier (F)), Make_List_Id (N)); Append_Node_To_List (N, Alternatives); end if; end if; F := Next_Node (F); end loop; -- Default case alternative (when others => null;) N := Make_Case_Statement_Alternative (No_List, No_List); Append_Node_To_List (N, Alternatives); -- Make the case statement N := Make_Case_Statement (Make_Defining_Identifier (PN (p_port)), Alternatives); -- If the thread is sporadic, the case statement is added -- directly to the thread job statements. If the thread -- is periodic, the case statement is executed only if -- 'Valid' is True. if P = thread_periodic then N := Make_If_Statement (Condition => Make_Defining_Identifier (PN (p_valid)), Then_Statements => Make_List_Id (N)); end if; Append_Node_To_List (N, Statements); end Make_Mode_Update; ------------------------- -- Make_Fetch_In_Ports -- ------------------------- procedure Make_Fetch_In_Ports is N : node_id; F : node_id; begin N := Message_Comment ("Get the IN port values"); Append_Node_To_List (N, Statements); F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) and then AAN.Is_Data (F) then -- Declare local variable N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (F, 'V'), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); Append_Node_To_List (N, Declarations); -- Assign the port value N := Make_Get_Valid_Value (F); Append_Node_To_List (N, Statements); end if; F := Next_Node (F); end loop; end Make_Fetch_In_Ports; --------------------------- -- Make_Dequeue_In_Ports -- --------------------------- procedure Make_Dequeue_In_Ports is N : node_id; F : node_id; begin N := Message_Comment ("Dequeue the IN port got values"); Append_Node_To_List (N, Statements); F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) and then Is_Event (F) then -- Create a qualified value of the port enumerator -- to avoid name clashing between ports N := Make_Record_Aggregate (Make_List_Id (Map_Ada_Defining_Identifier (F))); N := Make_Qualified_Expression (Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), N); -- Call Next_Value N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_next_value)), Make_List_Id (N)); Append_Node_To_List (N, Statements); end if; F := Next_Node (F); end loop; end Make_Dequeue_In_Ports; ------------------------ -- Make_Call_Sequence -- ------------------------ procedure Make_Call_Sequence is function In_Modes_To_Choices (L : list_id) return list_id; -- Converts an In_Modes (modes only) list into a case -- statement alternative choice list. ------------------------- -- In_Modes_To_Choices -- ------------------------- function In_Modes_To_Choices (L : list_id) return list_id is Choices : constant list_id := New_List (ADN.k_list_id); M : node_id; begin M := First_Node (L); while Present (M) loop Append_Node_To_List (Map_Ada_Defining_Identifier (Item (M)), Choices); M := Next_Node (M); end loop; return Choices; end In_Modes_To_Choices; Call_Seq : node_id := First_Node (Calls (E)); begin if not Has_Modes (E) or else AAU.Length (Calls (E)) = 1 then -- If the thread has no modes, then it should has one -- unique call sequence, handle it. Handle_Call_Sequence (E, Call_Seq, Declarations, Statements); else declare Alternatives : constant list_id := New_List (ADN.k_list_id); Alt_Sts : list_id; Default : Boolean := False; N : node_id; begin while Present (Call_Seq) loop -- Handle the call sequence inside the case -- alternative statements. Alt_Sts := New_List (ADN.k_statement_list); Handle_Call_Sequence (E, Call_Seq, Declarations, Alt_Sts); if not AAU.Is_Empty (AAN.Modes (In_Modes (Call_Seq))) then -- Generate a case statement alternative that -- handles this sequence. N := Make_Case_Statement_Alternative (In_Modes_To_Choices (Modes (In_Modes (Call_Seq))), Alt_Sts); Append_Node_To_List (N, Alternatives); else -- We are sure this is the unique call -- sequence without in_modes statement. As -- stated by the standard it qhould be used -- when none of the other call sequences -- match. N := Make_Case_Statement_Alternative (No_List, Alt_Sts); Append_Node_To_List (N, Alternatives); Default := True; end if; Call_Seq := Next_Node (Call_Seq); end loop; if not Default then -- Default case alternative (when others => null;) N := Make_Case_Statement_Alternative (No_List, No_List); Append_Node_To_List (N, Alternatives); end if; N := Make_Case_Statement (Make_Defining_Identifier (Map_Current_Mode_Name (E)), Alternatives); Append_Node_To_List (N, Statements); end; end if; end Make_Call_Sequence; ------------------------------------ -- Make_Thread_Compute_Entrypoint -- ------------------------------------ procedure Make_Thread_Compute_Entrypoint is N : node_id; Call_Profile : list_id; begin N := Message_Comment ("Call the thread compute entrypoint"); Append_Node_To_List (N, Statements); -- If the thread is periodic, then the compute entrypoint -- is a parameterless subprogram because the thread is -- triggered with a time event. If the thread is sporadic -- then the compute entrypoint takes one parameter which -- is the port that triggered the thread. if P = thread_periodic then Call_Profile := No_List; elsif P = thread_sporadic then Call_Profile := Make_List_Id (Make_Defining_Identifier (PN (p_port))); else -- This cannot happend unless a serious bug exists raise Program_Error with "A thread which is not periodic nor sporadic"; end if; -- If the thread has no modes, we just call the compute -- entrypoint. if not Has_Modes (E) then N := Make_Subprogram_Call (Map_Ada_Subprogram_Identifier (E), Call_Profile); Append_Node_To_List (N, Statements); else Display_Located_Error (Loc (E), "Threads with mode controled compute entrypoints not" & " supported yet", Fatal => True); end if; end Make_Thread_Compute_Entrypoint; ----------------------------------- -- Make_Ports_Compute_Entrypoint -- ----------------------------------- procedure Make_Ports_Compute_Entrypoint is N : node_id; F : node_id; Alternatives : constant list_id := New_List (ADN.k_list_id); begin N := Message_Comment ("Depending on the triggered port, call" & " the corresponding compute entrypoint."); Append_Node_To_List (N, Statements); F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) then declare St : constant list_id := New_List (ADN.k_statement_list); begin -- Declare local data variable if the port is a -- data port. if AAN.Is_Data (F) then N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (F, 'V'), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); Append_Node_To_List (N, Declarations); -- Assign the port value, if there is a match N := Make_Get_Valid_Value (F); Append_Node_To_List (N, St); end if; if Is_Event (F) then -- Create a qualified value of the port -- enumerator to avoid name clashing between -- ports. N := Make_Record_Aggregate (Make_List_Id (Map_Ada_Defining_Identifier (F))); N := Make_Qualified_Expression (Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), N); -- Call Next_Value N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_next_value)), Make_List_Id (N)); Append_Node_To_List (N, St); end if; -- Call the port compute entrypoint with the -- received value (if any). declare Profile : list_id := No_List; begin if AAN.Is_Data (F) then Profile := Make_List_Id (Map_Ada_Defining_Identifier (F, 'V')); end if; N := Make_Subprogram_Call (Map_Ada_Subprogram_Identifier (F), Profile); Append_Node_To_List (N, St); end; -- Make the case statement alternative N := Make_Case_Statement_Alternative (Make_List_Id (Map_Ada_Defining_Identifier (F)), St); Append_Node_To_List (N, Alternatives); end; end if; F := Next_Node (F); end loop; N := Make_Case_Statement_Alternative (No_List, Make_List_Id (Make_Raise_Statement (Make_Designator (EN (e_program_error))))); Append_Node_To_List (N, Alternatives); -- Make the case statement N := Make_Case_Statement (Make_Defining_Identifier (PN (p_port)), Alternatives); Append_Node_To_List (N, Statements); end Make_Ports_Compute_Entrypoint; ------------------------ -- Make_Set_Out_Ports -- ------------------------ procedure Make_Set_Out_Ports is N : node_id; F : node_id; begin N := Message_Comment ("Set the OUT port values"); Append_Node_To_List (N, Statements); F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_Out (F) then -- We do not set the ports that are connected to -- subprogram out ports, this should be done during -- the subprogram call sequence handling. declare D : node_id := First_Node (Sources (F)); Set : Boolean := True; begin while Present (D) loop Set := Kind (Item (D)) /= k_port_spec_instance; exit when not Set; D := Next_Node (D); end loop; if Set then N := Make_Record_Aggregate (Make_List_Id (Map_Ada_Defining_Identifier (F), Map_Ada_Defining_Identifier (F, 'V'))); N := Make_Qualified_Expression (Make_Defining_Identifier (Map_Port_Interface_Name (E)), N); N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_put_value)), Make_List_Id (N)); Append_Node_To_List (N, Statements); end if; end; end if; F := Next_Node (F); end loop; end Make_Set_Out_Ports; ------------------------- -- Make_Send_Out_Ports -- ------------------------- procedure Make_Send_Out_Ports is N : node_id; F : node_id; begin N := Message_Comment ("Send the OUT ports"); Append_Node_To_List (N, Statements); F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_Out (F) then N := Make_Subprogram_Call (Get_Fully_Qualified_Subprogram (SN (s_send_output)), Make_List_Id (Map_Ada_Defining_Identifier (F))); Append_Node_To_List (N, Statements); end if; F := Next_Node (F); end loop; end Make_Send_Out_Ports; --------------------------------- -- Make_Sporadic_Task_Blocking -- --------------------------------- procedure Make_Sporadic_Task_Blocking is N : node_id; begin N := Make_Delay_Statement (Expression => Make_Defining_Identifier (PN (p_next_start)), Is_Until => True); Append_Node_To_List (N, Statements); end Make_Sporadic_Task_Blocking; N : node_id; begin Check_Thread_Consistency (E); -- If the thread is sporadic, we generate the call to block -- waiting for events. if P = thread_sporadic then Make_Wait_Event; end if; -- If the thread contains operational modes. we update the -- value of the current mode depending on the received -- events. if Has_Modes (E) then Make_Mode_Update; end if; -- Depending on the implementation kind, call the proper -- implementation routines. case Impl_Kind is when thread_with_call_sequence => -- This kind of implementation is the simplest -- one. The user has only to implementation the -- behaviour of subprograms and does not have to worry -- about sending and receiving ports. -- Get IN ports values and dequeue them if Has_In_Ports (E) then Make_Fetch_In_Ports; Make_Dequeue_In_Ports; end if; -- Handle the thread call sequences if not AAU.Is_Empty (Calls (E)) then Make_Call_Sequence; end if; -- Set OUT ports values if Has_Out_Ports (E) then Make_Set_Out_Ports; end if; -- Send OUT ports if Has_Out_Ports (E) then Make_Send_Out_Ports; end if; when thread_with_compute_entrypoint => -- Call the compute entrypoint. The code of the -- compute entry point will include the setting of -- the thread OUT ports. Make_Thread_Compute_Entrypoint; -- Send OUT ports. -- FIXME: Depending on an AADL property, the code of -- the thread entrypoint may include the sending of -- OUT ports. if Has_Out_Ports (E) then Make_Send_Out_Ports; end if; when thread_with_port_compute_entrypoint => -- Call the compute entrypoints of the triggeing -- port. The code of the compute entry point will -- include the sentting of the thread OUT ports. Make_Ports_Compute_Entrypoint; -- Send OUT ports. -- FIXME: Depending on an AADL property, the code of -- the port entrypoints may include the sending of OUT -- ports. if Has_Out_Ports (E) then Make_Send_Out_Ports; end if; when others => raise Program_Error with "Unconsistency in Task_Job_Body"; end case; -- Block until the next dispatch with respect to the -- inter-arrival time in case of a sporadic thread. if P = thread_sporadic then Make_Sporadic_Task_Blocking; end if; N := Make_Subprogram_Implementation (Spec, Declarations, Statements); return N; end Task_Job_Body; ---------------------------- -- Runtime_Routine_Bodies -- ---------------------------- procedure Runtime_Routine_Bodies (E : node_id) is N : node_id; begin -- Declare the _Integer_Array type N := Make_Full_Type_Declaration (Make_Defining_Identifier (Map_Integer_Array_Name (E)), Make_Array_Type_Definition (Make_List_Id (Make_Defining_Identifier (Map_Port_Enumeration_Name (E))), RE (re_integer))); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Declare the FIFO size related entities declare F : node_id; FIFO_Sizes_Aggregate : constant list_id := New_List (ADN.k_element_list); Offset_Aggregate : constant list_id := New_List (ADN.k_element_list); Total_FIFO_Size : unsigned_long_long := 0; Queue_Size : long_long; Queue_Size_V : value_id; Offset_V : value_id; begin F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then -- Convention for queue sizes: -- IN [OUT] EVENT [DADA] ports: user-specified or -- else default value. -- IN [OUT] DATA ports: -1 -- OUT [EVENT] [DATA] ports: -2 Queue_Size := 0; if Is_Out (F) then Queue_Size_V := New_Integer_Value (2, -1, 10); Offset_V := New_Integer_Value (0, 1, 10); elsif AAN.Is_Data (F) and then not Is_Event (F) then Queue_Size_V := New_Integer_Value (1, -1, 10); Offset_V := New_Integer_Value (0, 1, 10); else Queue_Size := Get_Queue_Size (F); if Queue_Size = -1 then Queue_Size := default_queue_size; -- For the calculation of the total queue -- size. -- Allocate a default size Queue_Size_V := New_Integer_Value (default_queue_size, 1, 10); elsif Queue_Size = 0 then -- 0 length queues are not supported Display_Located_Error (Loc (F), "Zero length port queues are not supported", Fatal => True); else Queue_Size_V := New_Integer_Value (unsigned_long_long (Queue_Size), 1, 10); end if; -- The offset value is equal to the current -- value of Total_FIFO_Size + 1. Offset_V := New_Integer_Value (Total_FIFO_Size + 1, 1, 10); end if; -- Element association for the FIFO sizes array N := Make_Element_Association (Map_Ada_Defining_Identifier (F), Make_Literal (Queue_Size_V)); Append_Node_To_List (N, FIFO_Sizes_Aggregate); -- Element association for the offset array N := Make_Element_Association (Map_Ada_Defining_Identifier (F), Make_Literal (Offset_V)); Append_Node_To_List (N, Offset_Aggregate); -- Update the global FIFO size in case Queue_Size is -- positive. if Queue_Size > 0 then Total_FIFO_Size := Total_FIFO_Size + unsigned_long_long (Queue_Size); end if; end if; F := Next_Node (F); end loop; -- Declare the entities N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_FIFO_Sizes_Name (E)), Object_Definition => Make_Defining_Identifier (Map_Integer_Array_Name (E)), Constant_Present => True, Expression => Make_Array_Aggregate (FIFO_Sizes_Aggregate)); Append_Node_To_List (N, ADN.Statements (Current_Package)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Offsets_Name (E)), Object_Definition => Make_Defining_Identifier (Map_Integer_Array_Name (E)), Constant_Present => True, Expression => Make_Array_Aggregate (Offset_Aggregate)); Append_Node_To_List (N, ADN.Statements (Current_Package)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Total_Size_Name (E)), Object_Definition => RE (re_integer), Constant_Present => True, Expression => Make_Literal (New_Integer_Value (Total_FIFO_Size, 1, 10))); Append_Node_To_List (N, ADN.Statements (Current_Package)); end; -- Declare the _Address_Array type N := Make_Full_Type_Declaration (Make_Defining_Identifier (Map_Address_Array_Name (E)), Make_Array_Type_Definition (Make_List_Id (Make_Defining_Identifier (Map_Port_Enumeration_Name (E))), RE (re_address))); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- For each OUT port, we create an array of its -- destinations, we declare the number of its destinations -- and create an element association in the global -- destinations array. declare F : node_id; N_Destination_Aggregate : constant list_id := New_List (ADN.k_element_list); Destination_Aggregate : constant list_id := New_List (ADN.k_element_list); begin F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then -- For OUT ports, we generatean array to indicate -- their destintions and we put relevant element -- association in the N_Destinations and the -- Destinnations arrays. For IN ports, we generate -- nothing and we put dummy element association. if Is_Out (F) then declare D : node_id; Port_Dst_Aggregate : constant list_id := New_List (ADN.k_element_list); Destinations : constant list_id := Get_Destination_Ports (F); Dst_Index : unsigned_long_long := 1; begin if AAU.Is_Empty (Destinations) then Display_Located_Error (Loc (F), "This OUT port is not connected to any" & " destination", Fatal => True); end if; D := First_Node (Destinations); while Present (D) loop N := Make_Element_Association (Make_Literal (New_Integer_Value (Dst_Index, 1, 10)), Make_Defining_Identifier (Map_Ada_Full_Feature_Name (Item (D), 'K'))); Append_Node_To_List (N, Port_Dst_Aggregate); Dst_Index := Dst_Index + 1; D := Next_Node (D); end loop; -- Declare the port specific destination -- array. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Destination_Name (F)), Object_Definition => Make_Array_Type_Definition (Range_Constraints => Make_List_Id (Make_Range_Constraint (No_Node, No_Node, RE (re_positive))), Component_Definition => RE (re_port_type_1)), Constant_Present => True, Expression => Make_Array_Aggregate (Port_Dst_Aggregate)); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Update the element associations of the -- N_Destinations and the Destinations -- arrays. N := Make_Element_Association (Map_Ada_Defining_Identifier (F), Make_Literal (New_Integer_Value (unsigned_long_long (AAU.Length (Destinations)), 1, 10))); Append_Node_To_List (N, N_Destination_Aggregate); N := Make_Element_Association (Map_Ada_Defining_Identifier (F), Make_Attribute_Designator (Make_Designator (Map_Destination_Name (F)), a_address)); Append_Node_To_List (N, Destination_Aggregate); end; else -- Dummy element associations N := Make_Element_Association (Map_Ada_Defining_Identifier (F), Make_Literal (New_Integer_Value (0, 1, 10))); Append_Node_To_List (N, N_Destination_Aggregate); N := Make_Element_Association (Map_Ada_Defining_Identifier (F), RE (re_null_address)); Append_Node_To_List (N, Destination_Aggregate); end if; end if; F := Next_Node (F); end loop; -- Declare the N_Destinations and the Destinations -- arrays. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_N_Destination_Name (E)), Object_Definition => Make_Defining_Identifier (Map_Integer_Array_Name (E)), Constant_Present => True, Expression => Make_Array_Aggregate (N_Destination_Aggregate)); Append_Node_To_List (N, ADN.Statements (Current_Package)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Destination_Name (E)), Object_Definition => Make_Defining_Identifier (Map_Address_Array_Name (E)), Constant_Present => True, Expression => Make_Array_Aggregate (Destination_Aggregate)); Append_Node_To_List (N, ADN.Statements (Current_Package)); end; -- Instantiate the PolyORB_HI.Interrogators generic declare Inst_Profile : constant list_id := New_List (ADN.k_parameter_profile); begin -- The 'Port_Type' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (TN (t_port_type)), Make_Defining_Identifier (Map_Port_Enumeration_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Integer_Array' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (TN (t_integer_array)), Make_Defining_Identifier (Map_Integer_Array_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Address_Array' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (TN (t_address_array)), Make_Defining_Identifier (Map_Address_Array_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Thread_Interface' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (TN (t_thread_interface_type)), Make_Defining_Identifier (Map_Port_Interface_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Current_Entity' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_current_entity)), Make_Defining_Identifier (Map_Ada_Enumerator_Name (Parent_Subcomponent (E)))); Append_Node_To_List (N, Inst_Profile); -- The 'Thread_Fifo_Sizes' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_thread_fifo_sizes)), Make_Defining_Identifier (Map_FIFO_Sizes_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Thread_Fifo_Offsets' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_thread_fifo_offsets)), Make_Defining_Identifier (Map_Offsets_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Global_Data_Queue_Size' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_global_data_queue_size)), Make_Defining_Identifier (Map_Total_Size_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'N_Destinations' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_n_destinations)), Make_Defining_Identifier (Map_N_Destination_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Destinations' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_destinations)), Make_Defining_Identifier (Map_Destination_Name (E))); Append_Node_To_List (N, Inst_Profile); -- The 'Marshall' generic formal N := Make_Parameter_Association (Make_Defining_Identifier (SN (s_marshall)), Extract_Designator (ADN.Marshall_Node (Backend_Node (Identifier (E))))); Append_Node_To_List (N, Inst_Profile); N := Make_Package_Instantiation (Defining_Identifier => Make_Defining_Identifier (Map_Interrogators_Name (E)), Generic_Package => RU (ru_polyorb_hi_thread_interrogators), Parameter_List => Inst_Profile); Append_Node_To_List (N, ADN.Statements (Current_Package)); end; -- Implementations of the runtime routines. declare procedure Rename_Subprogram (Spec : node_id); -- Generate a renamed subprogram from the given spec. The -- renamed subprogram is the one having the same name -- from the instantiated package above. -- IMPORTANT: Internals of spec will be altered. ----------------------- -- Rename_Subprogram -- ----------------------- procedure Rename_Subprogram (Spec : node_id) is Renamed : constant node_id := Make_Defining_Identifier (ADN.Name (ADN.Defining_Identifier (Spec))); begin Set_Homogeneous_Parent_Unit_Name (Renamed, Make_Defining_Identifier (Map_Interrogators_Name (E))); ADN.Set_Renamed_Entity (Spec, Renamed); Append_Node_To_List (Spec, ADN.Statements (Current_Package)); end Rename_Subprogram; begin -- All the runtime routines are renaming of the routines -- of the same name provided by the generic -- instantiation. -- Send_Output Rename_Subprogram (Send_Output_Spec (E)); -- Put_Value Rename_Subprogram (Put_Value_Spec (E)); -- Receive_Input Rename_Subprogram (Receive_Input_Spec (E)); -- Get_Value Rename_Subprogram (Get_Value_Spec (E)); -- Get_Count Rename_Subprogram (Get_Count_Spec (E)); -- Next_Value Rename_Subprogram (Next_Value_Spec (E)); -- Wait_For_Incoming_Events Rename_Subprogram (Wait_For_Incoming_Events_Spec (E)); end; end Runtime_Routine_Bodies; ------------------ -- Deliver_Body -- ------------------ function Deliver_Body (E : node_id) return node_id is Spec : constant node_id := ADN.Deliver_Node (Backend_Node (Identifier (E))); Declarations : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); Alternatives : constant list_id := New_List (ADN.k_list_id); N : node_id; T : node_id; begin pragma assert (Is_Process (E)); -- Declarative part N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_msg)), Object_Definition => RE (re_message_type)); Append_Node_To_List (N, Declarations); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Object_Definition => RE (re_port_type_1)); Append_Node_To_List (N, Declarations); -- Add a use clause for the Ada.Streams.Stream_Element_Offse -- type to have visibility on its operators. N := Make_Used_Type (RE (re_stream_element_offset)); Append_Node_To_List (N, Declarations); -- Statements -- Get the message payload N := Make_Used_Type (RE (re_stream_element_offset)); Append_Node_To_List (N, Declarations); N := Make_Expression (Make_Attribute_Designator (Make_Designator (PN (p_message)), a_first), op_plus, RE (re_header_size)); N := Make_Range_Constraint (N, Make_Attribute_Designator (Make_Designator (PN (p_message)), a_last)); N := Make_Subprogram_Call (Make_Designator (PN (p_message)), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_write), Make_List_Id (Make_Defining_Identifier (PN (p_msg)), N)); Append_Node_To_List (N, Statements); -- Unmarshall the destination port N := Make_Subprogram_Call (Extract_Designator (ADN.Unmarshall_Node (Backend_Node (Identifier (E)))), Make_List_Id (Make_Defining_Identifier (PN (p_port)), Make_Defining_Identifier (PN (p_msg)))); Append_Node_To_List (N, Statements); -- The case statement: For each thread of the current -- process, we generate a case statement alternative to call -- its specific delivery routine. T := First_Node (Subcomponents (E)); while Present (T) loop if Is_Thread (Corresponding_Instance (T)) and then Has_In_Ports (Corresponding_Instance (T)) then -- Generate the spec of the internal delivery routine -- of thread T. It is important to do this before -- adding the global delivery body to the package -- statemnets because it used the internal delivery -- routines. N := Internal_Delivery_Spec (Corresponding_Instance (T)); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Call the internal delivery routine of the thread N := Make_Subprogram_Call (Make_Defining_Identifier (Map_Deliver_Name (Corresponding_Instance (T))), Make_List_Id (Make_Defining_Identifier (PN (p_port)), Make_Defining_Identifier (PN (p_msg)))); -- The case statement alternative N := Make_Case_Statement_Alternative (Make_List_Id (Make_Defining_Identifier (Map_Ada_Enumerator_Name (T))), Make_List_Id (N)); Append_Node_To_List (N, Alternatives); end if; T := Next_Node (T); end loop; -- Raise an error if other threads are targeted. N := Make_Case_Statement_Alternative (No_List, Make_List_Id (Make_Raise_Statement (Make_Designator (EN (e_program_error))))); Append_Node_To_List (N, Alternatives); -- The switch case statement N := Make_Case_Statement (Make_Defining_Identifier (PN (p_entity)), Alternatives); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarations, Statements); return N; end Deliver_Body; ---------------------------- -- Internal_Delivery_Spec -- ---------------------------- function Internal_Delivery_Spec (E : node_id) return node_id is Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin -- The Port parameter N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_port)), Subtype_Mark => RE (re_port_type_1), Parameter_Mode => mode_in); Append_Node_To_List (N, Profile); -- The Msg parameter N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_msg)), Subtype_Mark => RE (re_message_type), Parameter_Mode => mode_inout); Append_Node_To_List (N, Profile); -- The subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (Map_Deliver_Name (E)), Parameter_Profile => Profile, Return_Type => No_Node); return N; end Internal_Delivery_Spec; ---------------------------- -- Internal_Delivery_Body -- ---------------------------- function Internal_Delivery_Body (E : node_id) return node_id is Spec : constant node_id := Internal_Delivery_Spec (E); Declarations : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); Alternatives : constant list_id := New_List (ADN.k_list_id); N : node_id; F : node_id; begin if not AAU.Is_Empty (Features (E)) and then Has_In_Ports (E) then -- Declare a local variable of type the thread interface N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (v_thread_interface)), Object_Definition => Make_Defining_Identifier (Map_Port_Interface_Name (E))); Append_Node_To_List (N, Declarations); -- For each port of the thread, create a switch case -- alternative to store the message to the proper -- destination. F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) then declare St : constant list_id := New_List (ADN.k_statement_list); begin -- Unmarshall the received message N := Make_Subprogram_Call (Extract_Designator (ADN.Unmarshall_Node (Backend_Node (Identifier (E)))), Make_List_Id (Map_Ada_Defining_Identifier (F), Make_Defining_Identifier (VN (v_thread_interface)), Make_Defining_Identifier (PN (p_msg)))); Append_Node_To_List (N, St); -- Store the received message N := Make_Defining_Identifier (SN (s_store_received_message)); Set_Homogeneous_Parent_Unit_Name (N, Make_Defining_Identifier (Map_Interrogators_Name (E))); N := Make_Subprogram_Call (N, Make_List_Id (Make_Defining_Identifier (VN (v_thread_interface)))); Append_Node_To_List (N, St); -- Create the case statement alternative N := Make_Case_Statement_Alternative (Make_List_Id (Make_Defining_Identifier (Map_Ada_Full_Feature_Name (F, 'K'))), St); Append_Node_To_List (N, Alternatives); end; end if; F := Next_Node (F); end loop; -- Raise an error if other ports are targeted. N := Make_Case_Statement_Alternative (No_List, Make_List_Id (Make_Raise_Statement (Make_Designator (EN (e_program_error))))); Append_Node_To_List (N, Alternatives); -- The switch case statement N := Make_Case_Statement (Make_Defining_Identifier (PN (p_port)), Alternatives); Append_Node_To_List (N, Statements); end if; N := Make_Subprogram_Implementation (Spec, Declarations, Statements); return N; end Internal_Delivery_Body; ---------------------------- -- Make_Modes_Enumeration -- ---------------------------- function Make_Modes_Enumeration (E : node_id) return node_id is Enum_List : constant list_id := New_List (ADN.k_enumeration_literals); M : node_id; N : node_id; begin M := First_Node (Modes (E)); while Present (M) loop N := Map_Ada_Defining_Identifier (M); Append_Node_To_List (N, Enum_List); M := Next_Node (M); end loop; N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)), Type_Definition => Make_Enumeration_Type_Definition (Enum_List)); return N; end Make_Modes_Enumeration; ----------------------------------- -- Make_Current_Mode_Declaration -- ----------------------------------- function Make_Current_Mode_Declaration (E : node_id) return node_id is M : node_id; N : node_id; begin -- The value of the global variable is the enumeratioin -- literal corresponding to the initial mode of the thread. M := First_Node (Modes (E)); N := No_Node; while Present (M) loop if Is_Initial (M) then N := Map_Ada_Defining_Identifier (M); exit; end if; M := Next_Node (M); end loop; -- If no initial mode has been found, there is definitely an -- error in the analyzer. if No (N) then raise Program_Error with "No initial mode in mode list"; end if; -- Declare the variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Current_Mode_Name (E)), Object_Definition => Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)), Expression => N); return N; end Make_Current_Mode_Declaration; ----------- -- Visit -- ----------- procedure Visit (E : node_id) is begin case Kind (E) is when k_architecture_instance => Visit_Architecture_Instance (E); when k_component_instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : node_id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Visit_System_Instance (E); when cc_process => Visit_Process_Instance (E); when cc_thread => Visit_Thread_Instance (E); when others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is U : constant node_id := ADN.Distributed_Application_Unit (ADN.Naming_Node (Backend_Node (Identifier (E)))); P : constant node_id := ADN.Entity (U); S : node_id; N : node_id; begin Push_Entity (P); Push_Entity (U); Set_Activity_Body; -- Generate a delivery body if necessary if Need_Delivery (E) then N := Deliver_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin Push_Entity (HI_Distributed_Application_Root); -- Visit all the subcomponents of the system if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- HI_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is P : constant supported_thread_dispatch_protocol := Get_Thread_Dispatch_Protocol (E); S : constant node_id := Parent_Subcomponent (E); N : node_id; begin if P = thread_periodic then N := Message_Comment ("Periodic task : " & Get_Name_String (Display_Name (Identifier (S)))); Append_Node_To_List (N, ADN.Statements (Current_Package)); elsif P = thread_sporadic then N := Message_Comment ("Sporadic task : " & Get_Name_String (Display_Name (Identifier (S)))); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; if Has_Ports (E) then -- Implement the routines that allow user code to -- manipulate the thread. Runtime_Routine_Bodies (E); end if; if Has_In_Ports (E) then -- Generate the body of the internal delivery routine of -- thread T. It is important to do this after the -- declaration of the runtime routines implementations -- because the internal delivery routine uses them. N := Internal_Delivery_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; if Has_Modes (E) then -- If the thread has operational modes, then generate the -- enumeration type correspodning to the thread mode list -- and the global variable designating the current -- mode. there is no harm using a global variable because -- it is accessed exclusively by the thread. N := Make_Modes_Enumeration (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); N := Make_Current_Mode_Declaration (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); null; end if; -- Create the body of the parameterless subprogram that -- executes the thread job. N := Task_Job_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); end Visit_Thread_Instance; end Package_Body; end Ocarina.Generators.PO_HI_Ada.Activity;