---------------------------------- ---------------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P O _ H I _ A D A . N A M I N G -- -- -- -- 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.PO_HI_Ada.Mapping; with Ocarina.Generators.PO_HI_Ada.Runtime; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_HI_Ada.Naming 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.PO_HI_Ada.Mapping; use Ocarina.Generators.PO_HI_Ada.Runtime; use Ocarina.Generators.Ada_Tree.Nutils; use Ocarina.Generators.Ada_Values; package ADV renames Ocarina.Generators.Ada_Values; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; ------------------ -- 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); function Added_Internal_Name (P : Node_Id; E : Node_Id) return Name_Id; function Is_Added (P : Node_Id; E : Node_Id) return Boolean; procedure Set_Added (P : Node_Id; E : Node_Id); -- Used to ensure that the naming information are added only -- for the nodes connected to a particular node. function Socket_Naming_Information (E : Node_Id) return Node_Id; -- Build an array element association that contains the -- informations about a particular node of the distributed -- application. Used when the generated code is supposed to run -- on the native platform using the GNAT.Socket library for -- transport. function SpaceWire_Naming_Information (E : Node_Id) return Node_Id; -- Same as above but used when the generated code is supposed -- to run on the LEON platform using the SpaceWire fieldbus. ------------------------- -- Added_Internal_Name -- ------------------------- function Added_Internal_Name (P : Node_Id; E : Node_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("%naming%info%"); Add_Nat_To_Name_Buffer (Nat (P)); Add_Char_To_Name_Buffer ('%'); Add_Nat_To_Name_Buffer (Nat (E)); return Name_Find; end Added_Internal_Name; -------------- -- Is_Added -- -------------- function Is_Added (P : Node_Id; E : Node_Id) return Boolean is I_Name : constant Name_Id := Added_Internal_Name (P, E); begin return Get_Name_Table_Byte (I_Name) = 1; end Is_Added; --------------- -- Set_Added -- --------------- procedure Set_Added (P : Node_Id; E : Node_Id) is I_Name : constant Name_Id := Added_Internal_Name (P, E); begin Set_Name_Table_Byte (I_Name, 1); end Set_Added; ------------------------------- -- Socket_Naming_Information -- ------------------------------- function Socket_Naming_Information (E : Node_Id) return Node_Id is Location : Name_Id; Port_Number : Value_Id; N : Node_Id; L : Node_Id; P : Node_Id; begin pragma Assert (Is_Process (E)); Location := Get_Processor_Location (Get_Bound_Processor (E)); Port_Number := Get_Process_Port_Number (E); -- If the node does not have a port number, we don't assign -- information to it. if Port_Number = ADV.No_Value then L := Make_Subprogram_Call (RE (RE_No_Inet_Addr)); P := Make_Subprogram_Call (RE (RE_No_Port)); else -- Every node that has a port number must be bound to a -- processor that have a location. if Location = No_Name then Display_Located_Error (Loc (Parent_Subcomponent (E)), "A process that has a port number must be bound" & " to a processor that has a location", Fatal => True); end if; L := Make_Subprogram_Call (RE (RE_Inet_Addr), Make_List_Id (Make_Literal (New_String_Value (Location)))); P := Make_Subprogram_Call (RE (RE_Port_Type_2), Make_List_Id (Make_Literal (To_Ada_Value (Port_Number)))); end if; -- Build the record aggregate N := Make_Record_Aggregate (Make_List_Id (RE (RE_Family_Inet), L, P)); N := Make_Element_Association (Make_Defining_Identifier (Map_Ada_Enumerator_Name (Parent_Subcomponent (E))), N); return N; end Socket_Naming_Information; ---------------------------------- -- SpaceWire_Naming_Information -- ---------------------------------- function SpaceWire_Naming_Information (E : Node_Id) return Node_Id is Outer_Aggreg : constant List_Id := New_List (ADN.K_Component_List); Inner_Aggreg : constant List_Id := New_List (ADN.K_Component_List); Proc_Id : constant Value_Id := Get_Process_Id (E); Channel_Addr : constant Value_Id := Get_Channel_Address (E); N : Node_Id; begin -- The name component N := Make_Component_Association (Make_Defining_Identifier (CN (C_Name)), Make_Attribute_Designator (Make_Subprogram_Call (Map_Node_Name_Identifier (Parent_Subcomponent (E)), Make_List_Id (Make_Attribute_Designator (Map_Node_Name_Identifier (Parent_Subcomponent (E)), A_First))), A_Access)); Append_Node_To_List (N, Outer_Aggreg); -- The address component -- Inner record aggregate -- Pid N := Make_Component_Association (Make_Defining_Identifier (CN (C_Pid)), RE (RE_SOIF_MTS_ASSERT_V1_SPACEWIRE_PID)); Append_Node_To_List (N, Inner_Aggreg); -- Los N := Make_Component_Association (Make_Defining_Identifier (CN (C_Los)), RE (RE_SOIF_MTS_NON_GUARANTEED_DELIVERY)); Append_Node_To_List (N, Inner_Aggreg); -- Address if Channel_Addr = ADV.No_Value then Display_Located_Error (Loc (Parent_Subcomponent (E)), "A process must have a channel address if it used SpaceWire", Fatal => True); end if; N := Make_Component_Association (Make_Defining_Identifier (CN (C_Address)), Make_Literal (To_Ada_Value (Channel_Addr))); Append_Node_To_List (N, Inner_Aggreg); -- Proc_Id if Proc_Id = ADV.No_Value then Display_Located_Error (Loc (Parent_Subcomponent (E)), "A process must have a process id if it used SpaceWire", Fatal => True); end if; N := Make_Component_Association (Make_Defining_Identifier (CN (C_Proc_Id)), Make_Literal (To_Ada_Value (Proc_Id))); Append_Node_To_List (N, Inner_Aggreg); N := Make_Component_Association (Make_Defining_Identifier (CN (C_Address)), Make_Record_Aggregate (Inner_Aggreg)); Append_Node_To_List (N, Outer_Aggreg); -- The result N := Make_Component_Association (Make_Defining_Identifier (Map_Ada_Enumerator_Name (Parent_Subcomponent (E))), Make_Record_Aggregate (Outer_Aggreg)); return N; end SpaceWire_Naming_Information; ----------- -- 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 others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : Node_Id) is P : constant Node_Id := Map_HI_Node (E); U : Node_Id; N : Node_Id; S : Node_Id; F : Node_Id; B : Node_Id; C : Node_Id; C_End : Node_Id; End_List : List_Id; Parent : Node_Id; Naming_Table_List : constant List_Id := New_List (ADN.K_List_Id); Platform : constant Supported_Execution_Platform := Get_Execution_Platform (Get_Bound_Processor (E)); Root_Sys : constant Node_Id := Parent_Component (Parent_Subcomponent (E)); Max_Bindings : Unsigned_Long_Long; Transport_API : Supported_Transport_APIs := Transport_None; begin -- FIXME: For now, all the generated naming table are -- identical for all the application nodes. We do not -- generate a unique name table because this desingn is -- likely to evolve to generate for each node, a naming -- table that represent a partial view of the global naming -- table. pragma Assert (Is_System (Root_Sys)); -- Check that the process has indeed an execution platform if Platform = Platform_None then Display_Located_Error (Loc (Parent_Subcomponent (E)), "This process subcomponent is bound to a processor without" & " execution platform specification", Fatal => True); end if; Push_Entity (P); -- It is important that we push P at the top of the entity -- stack before generating the package unit. U := Map_HI_Unit (E); Push_Entity (U); Set_Naming_Spec; -- Make code readeable Add_With_Package (RU (RU_Deployment), Used => True); -- We perform a first loop to designates the nodes to be -- included in the naming table. For a particular node, the -- nodes that are in its naming table are (1) itself and (2) -- all the nodes directly connected to it. This factorizes a -- lot of code between the handling of the different -- platforms. -- In parallel, we check the consistency of the transport -- layers that have to be used by the connection involving -- these features. -- (1) Set_Added (E, E); -- (2) if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop -- We make two iteration to traverse (1) the sources -- of F then (2) the destinations of F. End_List := Sources (F); for I in Boolean'Range loop if not AAU.Is_Empty (End_List) then C_End := First_Node (End_List); while Present (C_End) loop Parent := Parent_Component (Item (C_End)); if Is_Process (Parent) then if Parent /= E then -- Mark the parent component of the -- remote feature as involved with the -- current process. Set_Added (Parent, E); end if; -- Get the connection involving C_End C := Extra_Item (C_End); if No (C) then -- There hasbeen definitly a bug while -- expanding connections. raise Program_Error with "Wrong expansion of connections"; end if; -- Get the bus of the connection B := Get_Bound_Bus (C); -- Get the transport layer of the Bus and -- verify that all the features use the -- same transport layer for thir -- connections. if Transport_API /= Transport_None and then Transport_API /= Get_Transport_API (B) then Display_Located_Error (Loc (Parent_Subcomponent (E)), "The features of this process are involved" & " in connetions that do not use the same" & " transport layer. This is not supported" & " for now.", Fatal => True); else Transport_API := Get_Transport_API (B); end if; end if; C_End := Next_Node (C_End); end loop; end if; -- In the next iteration, we traverse the -- Destinations of F. End_List := Destinations (F); end loop; F := Next_Node (F); end loop; end if; -- A useful marking (for future fetch of the transport layer) Bind_Transport_API (E, Transport_API); -- Generate the naming table case Transport_API is when Transport_BSD_Sockets => -- Build the node information for all the application -- nodes involved with the current one and append it -- to the naming list. S := First_Node (Subcomponents (Root_Sys)); while Present (S) loop if Is_Process (Corresponding_Instance (S)) and then Is_Added (Corresponding_Instance (S), E) then N := Socket_Naming_Information (Corresponding_Instance (S)); Append_Node_To_List (N, Naming_Table_List); end if; S := Next_Node (S); end loop; -- Declare the Naming Table N := Message_Comment ("Naming Table"); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- In the case the generated code use a non -- ravenscar-compliant transport mechaninsm, disable -- the warnings. N := Make_Pragma_Statement (Pragma_Warnings, Make_List_Id (RE (RE_Off))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Message_Comment ("Disable the ""Ravenscar"" warnings" & " (no implicit heap allocation)"); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Make_Array_Type_Definition (Range_Constraints => Make_List_Id (Make_Range_Constraint (No_Node, No_Node, Make_Attribute_Designator (Make_Designator (TN (T_Node_Type)), A_Range))), Component_Definition => RE (RE_Sock_Addr_Type)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Naming_Table)), Constant_Present => True, Object_Definition => N, Expression => Make_Array_Aggregate (Naming_Table_List)); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Re-enable the warnings N := Make_Pragma_Statement (Pragma_Warnings, Make_List_Id (RE (RE_On))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); when Transport_SpaceWire => N := Make_Used_Type (RE (RE_Char_Array)); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Build the node information for all application -- nodes involved with the currentone and append it to -- the naming list. Max_Bindings := 0; S := First_Node (Subcomponents (Root_Sys)); while Present (S) loop if Is_Process (Corresponding_Instance (S)) and then Is_Added (Corresponding_Instance (S), E) then -- Declare the string that contains the node name N := Make_Object_Declaration (Defining_Identifier => Map_Node_Name_Identifier (S), Object_Definition => RE (RE_Char_Array), Expression => Make_Expression (Make_Literal (New_String_Value (Map_Ada_Enumerator_Name (S))), Op_And_Symbol, RE (RE_Nul))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Build the node information N := SpaceWire_Naming_Information (Corresponding_Instance (S)); Append_Node_To_List (N, Naming_Table_List); Max_Bindings := Max_Bindings + 1; end if; S := Next_Node (S); end loop; -- Declare the Naming Table N := Message_Comment ("Naming Table"); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Make_Array_Type_Definition (Range_Constraints => Make_List_Id (Make_Range_Constraint (No_Node, No_Node, Make_Attribute_Designator (Make_Designator (TN (T_Node_Type)), A_Range))), Component_Definition => RE (RE_SOIF_MTS_Naming_Entry_Type), Aliased_Present => True); N := Make_Object_Declaration (Defining_Identifier => ADN.Defining_Identifier (RE (RE_SOIF_MTS_Naming_Entry)), Object_Definition => N, Expression => Make_Array_Aggregate (Naming_Table_List)); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Declare the naming store N := Make_Array_Aggregate (Make_List_Id (Make_Element_Association (Make_Defining_Identifier (PN (P_Size)), Make_Literal (New_Integer_Value (Max_Bindings, 1, 10))), Make_Element_Association (Make_Defining_Identifier (PN (P_Store)), Make_Attribute_Designator (Make_Subprogram_Call (RE (RE_SOIF_MTS_Naming_Entry), Make_List_Id (Make_Attribute_Designator (RE (RE_SOIF_MTS_Naming_Entry), A_First))), A_Access)))); N := Make_Object_Declaration (Defining_Identifier => ADN.Defining_Identifier (RE (RE_SOIF_MTS_Naming_Store)), Object_Definition => RE (RE_SOIF_MTS_Naming_Store_Type), Expression => N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Export the naming store to C N := Make_Pragma_Statement (Pragma_Export, Make_List_Id (Make_Defining_Identifier (PN (P_C)), RE (RE_SOIF_MTS_Naming_Store), Make_Literal (New_String_Value (Get_String_Name ("SOIF_MTS_Naming_store"))))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); when others => -- If we did not fetch a meaningful transport layer, -- this meand the application does not use the -- network. No naming table will be generated. null; end case; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : Node_Id) is A : constant Node_Id := Map_Distributed_Application (E); C : Node_Id; S : Node_Id; begin Push_Entity (A); -- Verify the consistency of the distributed application -- hierachy. if not AAU.Is_Empty (Connections (E)) then C := First_Node (Connections (E)); while Present (C) loop Check_Connection_Consistency (C); C := Next_Node (C); end loop; end if; -- 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; -- A end Visit_System_Instance; end Package_Spec; end Ocarina.Generators.PO_HI_Ada.Naming;