------------------------------------- ------------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P O _ Q O S _ A D A . M A I N -- -- -- -- 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 GNAT.OS_Lib; with GNAT.Expect; 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.PO_QoS_Ada.Runtime; with Ocarina.Generators.PO_QoS_Ada.Mapping; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_QoS_Ada.Main 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.PO_QoS_Ada.Runtime; use Ocarina.Generators.PO_QoS_Ada.Mapping; use Ocarina.Generators.Ada_Values; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; --------------------- -- Subprogram_Body -- --------------------- package body Subprogram_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); procedure ORB_Setup; -- Build the Setup clause according to the process properties function Get_IOR_Reference (Host_Location : name_id; Port_Number : unsigned_long_long; Servant_Index : unsigned_long_long; Creator : name_id; Protocol : name_id; Priority : unsigned_long_long) return name_id; -- Build an IOR reference according to the given infomation. -- FIXME: Investigate very deeply the possible interference -- with this function when using Map_Ada_Priority function Is_Real_Time (P : node_id) return Boolean; -- Return True if a process need an RT_POA to be installed type process_parameters_type is record Self : node_id; -- The current process N_Periodic_Threads : nat; N_Non_Periodic_Threads : nat; Get_Ref_List : list_id; -- Contains the statements to collect references to other -- ports which have to come after all the thread own -- refernce putting. Periodic_Thread_List : list_id; -- Contains the statements to create the periodic threads -- which have to come after all references have been put -- or got. end record; Current_Process_Parameters : process_parameters_type; Current_Distributed_Application : node_id; ------------------ -- Is_Real_Time -- ------------------ function Is_Real_Time (P : node_id) return Boolean is S : node_id; RT : Boolean := False; NT : Natural := 0; begin pragma assert (Is_Process (P)); if not AAU.Is_Empty (Subcomponents (P)) then S := First_Node (Subcomponents (P)); while Present (S) loop declare SC : node_id; P : unsigned_long_long; begin SC := Corresponding_Instance (S); if Is_Thread (SC) then P := Get_Thread_Priority (SC); NT := NT + 1; if P > 0 then RT := True; end if; end if; end; S := Next_Node (S); end loop; end if; -- A process needs an RT_POA if it contains more than one -- thread and if one of the threads has been assigned a -- priority. RT := RT and then NT > 1; return RT; end Is_Real_Time; ----------- -- 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.Helpers_Node (Backend_Node (Identifier (E)))); P : constant node_id := ADN.Entity (U); N : node_id; S : node_id; begin Push_Entity (P); Push_Entity (U); Set_Main_Body; -- Initialize the process parameters Current_Process_Parameters := (Self => E, N_Periodic_Threads => 0, N_Non_Periodic_Threads => 0, Get_Ref_List => New_List (ADN.k_statement_list), Periodic_Thread_List => New_List (ADN.k_statement_list)); -- First loop to update the process parameters if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop declare SC : node_id; DP : supported_thread_dispatch_protocol; begin SC := Corresponding_Instance (S); if Is_Thread (SC) then DP := Get_Thread_Dispatch_Protocol (SC); if DP /= thread_periodic and then DP /= thread_aperiodic and then DP /= thread_sporadic then Display_Located_Error (Loc (SC), "Unsupported thread dispatching protocol", Fatal => True); end if; if DP = thread_periodic then Current_Process_Parameters.N_Periodic_Threads := Current_Process_Parameters.N_Periodic_Threads + 1; else Current_Process_Parameters.N_Non_Periodic_Threads := Current_Process_Parameters.N_Non_Periodic_Threads + 1; end if; end if; end; S := Next_Node (S); end loop; end if; -- Initialize_World N := Make_Subprogram_Call (RE (re_initialize_world), No_List); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 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 corresponding component instance Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; -- Append the Get_Ref statements if not Is_Empty (Current_Process_Parameters.Get_Ref_List) then Append_Node_To_List (ADN.First_Node (Current_Process_Parameters.Get_Ref_List), ADN.Statements (Current_Package)); end if; -- Append the Periodic threads creation statements if not Is_Empty (Current_Process_Parameters.Periodic_Thread_List) then Append_Node_To_List (ADN.First_Node (Current_Process_Parameters.Periodic_Thread_List), ADN.Statements (Current_Package)); end if; -- Run the ORB if Has_In_Ports (E) then N := Make_Component_Association (Make_Defining_Identifier (PN (p_may_poll)), RE (re_true)); N := Make_Subprogram_Call (RE (re_run), Make_List_Id (RE (re_the_orb), N)); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; -- Setup the tasking runtime ORB_Setup; 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 Current_Distributed_Application := E; Push_Entity (QoS_Distributed_Application_Root); if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- QoS_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is N : node_id; L : list_id; F : node_id; D : node_id; Priority : constant unsigned_long_long := Get_Thread_Priority (E); Byte_Stack_Size : constant unsigned_long_long := Map_Ada_Size (Get_Thread_Stack_Size (E)); DP : constant supported_thread_dispatch_protocol := Get_Thread_Dispatch_Protocol (E); Binding_Done : Boolean := False; begin Set_Main_Body; -- Handle the thread features if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then if Is_In (F) then if not Binding_Done then Binding_Done := True; -- Binding between the Object implementation -- and the reference. N := Make_Object_Instantiation (Extract_Designator (ADN.Type_Definition_Node (Backend_Node (Identifier (E))))); if Is_Real_Time (Current_Process_Parameters.Self) then L := Make_List_Id (N, Extract_Designator (ADN.Reference_Node (Backend_Node (Identifier (E)))), Make_Literal (New_String_Value (Name (Identifier (Parent_Subcomponent (E)))))); if Priority /= 0 then Append_Node_To_List (Make_Literal (New_Integer_Value (Priority, 0, 10)), L); end if; N := Make_Subprogram_Call (RE (re_link_to_obj_adapter_2), L); else L := Make_List_Id (N, Extract_Designator (ADN.Reference_Node (Backend_Node (Identifier (E))))); N := Make_Subprogram_Call (RE (re_link_to_obj_adapter), L); end if; Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; end if; if Is_Out (F) then D := First_Node (Get_Destination_Ports (F)); while Present (D) loop declare Params : constant list_id := New_List (ADN.k_list_id); Parent_Thread : constant node_id := Parent_Component (Item (D)); Parent_Process : constant node_id := Parent_Component (Parent_Subcomponent (Parent_Thread)); Host_Location : constant name_id := Get_Processor_Location (Get_Bound_Processor (Parent_Process)); Port_Number : constant value_id := To_Ada_Value (Get_Process_Port_Number (Parent_Process)); -- At this point we are sure that the -- remote process has a valid port number -- because we generate the -- PolyORB.Parameters.Partition body -- before the main body. Creator : constant name_id := Name (Identifier (Parent_Subcomponent (Parent_Thread))); Protocol : constant protocol_type := Get_Protocol (Current_Distributed_Application); Remote_Priority : constant unsigned_long_long := Get_Thread_Priority (Parent_Thread); Servant_Index : constant unsigned_long_long := unsigned_long_long (Get_Servant_Index (Parent_Thread)); Proto_Name : name_id; begin -- Add a use clauyse to the servants -- package for more code lisibility. Add_With_Package (Extract_Designator (ADN.Servants_Package (Current_Entity), False), Used => True); -- Compute the reference of the remote -- thread. N := Map_Reference_Identifier (Item (D)); Append_Node_To_List (N, Params); -- The way the remoted reference is -- computed depends on the real-time -- characteristics of the application. if Is_Real_Time (Parent_Process) then case Protocol is when protocol_diop => Proto_Name := Get_String_Name ("diop"); when others => Proto_Name := Get_String_Name ("iiop"); end case; declare IOR : constant name_id := Get_IOR_Reference (Host_Location, Value (Port_Number).IVal, Servant_Index, Creator, Proto_Name, Remote_Priority); begin N := Make_Literal (New_String_Value (IOR)); Append_Node_To_List (N, Params); N := Make_Subprogram_Call (RE (re_get_giop_ref), Params); Append_Node_To_List (N, Current_Process_Parameters.Get_Ref_List); end; else N := Make_Literal (New_String_Value (Host_Location)); Append_Node_To_List (N, Params); N := Make_Literal (Port_Number); Append_Node_To_List (N, Params); N := Make_Literal (New_Integer_Value (Servant_Index, 1, 10)); Append_Node_To_List (N, Params); case Protocol is when protocol_diop => Set_Str_To_Name_Buffer ("diop"); when others => Set_Str_To_Name_Buffer ("iiop"); end case; N := Make_Literal (New_String_Value (Name_Find)); Append_Node_To_List (N, Params); N := Make_Subprogram_Call (RE (re_get_ref), Params); Append_Node_To_List (N, Current_Process_Parameters.Get_Ref_List); end if; end; D := Next_Node (D); end loop; end if; end if; F := Next_Node (F); end loop; end if; if DP = thread_periodic then Current_Process_Parameters.N_Periodic_Threads := Current_Process_Parameters.N_Periodic_Threads + 1; -- Create the periodic thread N := Extract_Designator (ADN.Thread_Controller_Node (Backend_Node (Identifier (E)))); N := Make_Attribute_Designator (N, a_access); N := Make_Component_Association (Make_Defining_Identifier (PN (p_tp)), N); L := Make_List_Id (N); if Priority /= 0 then N := Make_Literal (New_Integer_Value (Priority, 1, 10)); N := Make_Component_Association (Make_Defining_Identifier (PN (p_priority)), N); Append_Node_To_List (N, L); end if; if Byte_Stack_Size /= 0 then N := Make_Literal (New_Integer_Value (Byte_Stack_Size, 1, 10)); N := Make_Component_Association (Make_Defining_Identifier (PN (p_storage_size)), N); Append_Node_To_List (N, L); end if; N := Make_Subprogram_Call (RE (re_create_periodic_thread), L); Append_Node_To_List (N, Current_Process_Parameters.Periodic_Thread_List); else Current_Process_Parameters.N_Non_Periodic_Threads := Current_Process_Parameters.N_Non_Periodic_Threads + 1; end if; end Visit_Thread_Instance; --------------- -- ORB_Setup -- --------------- procedure ORB_Setup is Multitask : constant Boolean := (Current_Process_Parameters.N_Periodic_Threads + Current_Process_Parameters.N_Non_Periodic_Threads) > 1; N : node_id; begin if Multitask then -- Full tasking mode N := Message_Comment ("Full tasking mode"); Append_Node_To_List (N, ADN.Withed_Packages (Current_Package)); Add_With_Package (E => RU (ru_arao_setup_application, False), Used => False, Warnings_Off => True, Elaborated => True); Add_With_Package (E => RU (ru_arao_setup_tasking_full_tasking, False), Used => False, Warnings_Off => True, Elaborated => True); else -- No tasking mode N := Message_Comment ("No tasking mode"); Append_Node_To_List (N, ADN.Withed_Packages (Current_Package)); Add_With_Package (E => RU (ru_arao_setup_application, False), Used => False, Warnings_Off => True, Elaborated => True); Add_With_Package (E => RU (ru_arao_setup_tasking_no_tasking, False), Used => False, Warnings_Off => True, Elaborated => True); end if; end ORB_Setup; ----------------------- -- Get_IOR_Reference -- ----------------------- function Get_IOR_Reference (Host_Location : name_id; Port_Number : unsigned_long_long; Servant_Index : unsigned_long_long; Creator : name_id; Protocol : name_id; Priority : unsigned_long_long) return name_id is use GNAT.OS_Lib; use GNAT.Expect; Args : Argument_List := (new String'("-t"), new String'("IDL:AADL_Model:1.0"), new String'("-pn"), new String'("1"), new String'("-pt"), new String'(Get_Name_String (Protocol)), new String'("-i"), new String'(unsigned_long_long'image (Servant_Index)), new String'("-g"), new String'("-cr"), new String'("RTPOA_" & Get_Name_String (Creator)), new String'("-vmj"), new String'("1"), new String'("-vmn"), new String'("2"), new String'("-a"), new String'(Get_Name_String (Host_Location)), new String'("-p"), new String'(unsigned_long_long'image (Port_Number)), new String'("-cn"), new String'("2"), new String'("-ct"), new String'("code_set"), new String'("-char"), new String'("16#00010001#"), new String'("-s"), new String'("0"), new String'("-wchar"), new String'("16#00010100#"), new String'("-s"), new String'("2"), new String'("16#00010101#"), new String'("16#00010102#"), new String'("-ce"), new String'("-ct"), new String'("policies"), new String'("-pol_nb"), new String'("1"), new String'("-model"), new String'("SERVER_DECLARED"), new String'("-priority"), new String'(unsigned_long_long'image (Priority)), new String'("-ce"), new String'("-pe")); PO_CRR : constant String := "po_createref"; S : String_Access; Status : aliased Integer := 0; Path : String_Access := Getenv ("PATH"); begin -- Check whether 'po_createref' exists in the PATH S := Locate_Exec_On_Path (PO_CRR); if S = null then -- Deallocate the argument list for J in Args'range loop Free (Args (J)); end loop; Display_Error ("Command not found: " & PO_CRR, Fatal => True); else pragma debug (Display_Debug_Message (PO_CRR & ": " & S.all, True)); Name_Len := 0; for J in Args'range loop pragma debug (Add_Str_To_Name_Buffer (Args (J).all & " ")); null; end loop; pragma debug (Display_Debug_Message ("Options: " & Name_Buffer (1 .. Name_Len), True)); Free (S); end if; pragma debug (Display_Debug_Message ("PATH=" & Path.all, True)); Free (Path); -- Invoke po_createref declare PO_CRR_Output : constant String := Get_Command_Output (Command => PO_CRR, Arguments => Args, Input => "", Status => Status'access, Err_To_Out => True); begin -- Deallocate the argument list for J in Args'range loop Free (Args (J)); end loop; pragma debug (Display_Debug_Message (PO_CRR & " output: """ & PO_CRR_Output & """", True)); -- Verify we get indeed an IOR as a result if Status /= 0 then raise Program_Error with "po_createref termined abnormaly => " & "check for parameters specifications"; end if; if PO_CRR_Output'length < 4 or else PO_CRR_Output (PO_CRR_Output'first .. PO_CRR_Output'first + 3) /= "IOR:" then raise Program_Error with "Invalid IOR reference"; end if; -- Every thing went fine return Get_String_Name (PO_CRR_Output); end; end Get_IOR_Reference; end Subprogram_Body; end Ocarina.Generators.PO_QoS_Ada.Main;