ocarina-backends-po_hi_ada-main.adb 13.6 KB
Newer Older
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                           OCARINA COMPONENTS                             --
--                                                                          --
--      O C A R I N A . B A C K E N D S . P O _ H I _ A D A . M A I N       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
yoogx's avatar
yoogx committed
9
--    Copyright (C) 2006-2009 Telecom ParisTech, 2010-2017 ESA & ISAE.      --
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
--                                                                          --
-- Ocarina  is free software; you can redistribute it and/or modify under   --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion. 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.                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
jhugues's avatar
jhugues committed
27 28
--                 Ocarina is maintained by the TASTE project               --
--                      (taste-users@lists.tuxfamily.org)                   --
29 30
--                                                                          --
------------------------------------------------------------------------------
jhugues's avatar
jhugues committed
31

32
with Ocarina.Namet; use Ocarina.Namet;
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
with Ocarina.ME_AADL;
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.ME_AADL.AADL_Instances.Nutils;
with Ocarina.ME_AADL.AADL_Instances.Entities;
with Ocarina.Backends.PO_HI_Ada.Mapping;
use Ocarina.Backends.PO_HI_Ada.Mapping;

with Ocarina.Backends.Messages;
with Ocarina.Backends.Utils;
with Ocarina.Backends.Properties;
with Ocarina.Backends.Ada_Tree.Nutils;
with Ocarina.Backends.Ada_Tree.Nodes;
with Ocarina.Backends.PO_HI_Ada.Runtime;

package body Ocarina.Backends.PO_HI_Ada.Main is

   use Ocarina.ME_AADL;
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
   use Ocarina.ME_AADL.AADL_Instances.Entities;
   use Ocarina.Backends.Utils;
   use Ocarina.Backends.Properties;
   use Ocarina.Backends.Ada_Tree.Nutils;
   use Ocarina.Backends.PO_HI_Ada.Runtime;
   use Ocarina.Backends.Messages;

   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;

   ---------------------
   -- 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 Visit_Device_Instance (E : Node_Id);

yoogx's avatar
yoogx committed
75 76
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);

77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
      Has_Hybrid_Threads : Boolean := False;

      -----------
      -- 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
111 112
         Category : constant Component_Category :=
           Get_Category_Of_Component (E);
113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
      begin
         case Category 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_Device_Instance --
      ---------------------------

      procedure Visit_Device_Instance (E : Node_Id) is
134 135
         Entrypoint : constant Node_Id := Get_Thread_Initialize_Entrypoint (E);
         N          : Node_Id;
136 137 138 139 140

         function Get_Bus (Device : Node_Id) return Node_Id;

         function Get_Bus (Device : Node_Id) return Node_Id is
            The_System : Node_Id;
141
            S          : Node_Id;
142
         begin
143 144 145 146
            The_System :=
              Parent_Component
                (Parent_Subcomponent
                   (Corresponding_Instance (Parent_Subcomponent (Device))));
147 148 149 150 151 152 153 154 155 156 157 158 159

            pragma Assert (AINU.Is_System (The_System));

            if not AAU.Is_Empty (Connections (The_System)) then
               S := First_Node (Connections (The_System));

               --  Check whether a device is attached to this bus

               while Present (S) loop
                  if Kind (S) = K_Connection_Instance
                    and then Get_Category_Of_Connection (S) = CT_Access_Bus
                  then
                     if True
160
                        --  This device is connected to the bus
161

162 163 164
                       and then
                         Parent_Subcomponent (Device) =
                         Item (First_Node (Path (Destination (S))))
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
                     then
                        --  Note, for now, we assume there is only one
                        --  device at each end of the bus.

                        return Item (First_Node (Path (Source (S))));
                     end if;
                  end if;
                  S := Next_Node (S);
               end loop;
            end if;

            return No_Node;
         end Get_Bus;

      begin
         if Entrypoint /= No_Node then
181 182 183 184
            N :=
              Message_Comment
                ("Initialize device " &
                 Get_Name_String (Name (Identifier (E))));
185
            Append_Node_To_List (N, ADN.Statements (Current_Package));
186 187 188 189 190 191 192 193
            Add_With_Package
              (E    => RU (RU_PolyORB_HI_Generated_Naming),
               Used => True);

            N :=
              Make_Subprogram_Call
                (Map_Ada_Subprogram_Identifier (Entrypoint),
                 Make_List_Id (Map_Bus_Name (Get_Bus (E))));
194 195 196 197 198 199 200 201 202
            Append_Node_To_List (N, ADN.Statements (Current_Package));
         end if;
      end Visit_Device_Instance;

      ----------------------------
      -- Visit_Process_Instance --
      ----------------------------

      procedure Visit_Process_Instance (E : Node_Id) is
203 204 205 206 207 208
         U : constant Node_Id :=
           ADN.Distributed_Application_Unit
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
         P             : constant Node_Id                  := ADN.Entity (U);
         N             : Node_Id;
         Transport_API : constant Supported_Transport_APIs :=
209
           Fetch_Transport_API (E);
210 211
         The_System : constant Node_Id :=
           Parent_Component (Parent_Subcomponent (E));
212 213 214 215 216 217 218 219
         C : Node_Id;
      begin
         Push_Entity (P);
         Push_Entity (U);
         Set_Main_Body;

         --  Check that the process has indeed an execution platform

220 221
         if Get_Execution_Platform (Get_Bound_Processor (E)) =
           Platform_None
222 223 224
         then
            Display_Located_Error
              (Loc (Parent_Subcomponent (E)),
225 226
               "This process subcomponent is bound to a processor without" &
               " execution platform specification",
227 228 229 230 231 232 233 234 235
               Fatal => True);
         end if;

         --  Reset hybrid thread related global variables

         Has_Hybrid_Threads := False;

         --  Visit all the subcomponents of the process

yoogx's avatar
yoogx committed
236
         Visit_Subcomponents_Of (E);
237 238 239 240

         if Has_Hybrid_Threads then
            --  Unblock the hybrid task driver

241 242 243 244
            N :=
              Make_Subprogram_Call
                (RE (RE_Set_True),
                 Make_List_Id (RE (RE_Driver_Suspender)));
245 246 247 248 249
            Append_Node_To_List (N, ADN.Statements (Current_Package));
         end if;

         --  Declarative part

250 251 252 253 254
         N :=
           Make_Pragma_Statement
             (Pragma_Priority,
              Make_List_Id
                (Make_Attribute_Designator (RE (RE_Priority), A_Last)));
255 256 257 258 259 260 261 262 263
         Append_Node_To_List (N, ADN.Declarations (Current_Package));

         --  Statements

         --  Initialize default transport, if any

         if Transport_API /= Transport_None
           and then Transport_API /= Transport_User
         then
264 265
            N :=
              Message_Comment ("Initialize default communication subsystem");
266 267 268 269 270 271 272 273 274 275 276 277 278
            Append_Node_To_List (N, ADN.Statements (Current_Package));

            N := Make_Subprogram_Call (RE (RE_Initialize), No_List);
            Append_Node_To_List (N, ADN.Statements (Current_Package));
         end if;

         --  Visit all devices attached to the parent system that
         --  share the same processor as process E.

         if not AAU.Is_Empty (Subcomponents (The_System)) then
            C := First_Node (Subcomponents (The_System));
            while Present (C) loop
               if AAU.Is_Device (Corresponding_Instance (C))
279 280 281
                 and then
                   Get_Bound_Processor (Corresponding_Instance (C)) =
                   Get_Bound_Processor (E)
282
               then
283
                  Visit_Device_Instance (Corresponding_Instance (C));
284 285 286 287 288 289 290 291 292 293 294 295 296
               end if;
               C := Next_Node (C);
            end loop;
         end if;

         N := Message_Comment ("Unblock all user tasks");
         Append_Node_To_List (N, ADN.Statements (Current_Package));

         N := Make_Subprogram_Call (RE (RE_Unblock_All_Tasks));
         Append_Node_To_List (N, ADN.Statements (Current_Package));

         --  Suspend forever the main task

297 298 299 300 301
         N :=
           Message_Comment
             ("Suspend forever instead of putting an" &
              " endless loop. This saves the CPU" &
              " resources.");
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
         Append_Node_To_List (N, ADN.Statements (Current_Package));

         N := Make_Subprogram_Call (RE (RE_Suspend_Forever));
         Append_Node_To_List (N, ADN.Statements (Current_Package));

         Pop_Entity; -- U
         Pop_Entity; -- P
      end Visit_Process_Instance;

      ---------------------------
      -- Visit_System_Instance --
      ---------------------------

      procedure Visit_System_Instance (E : Node_Id) is
      begin
         Push_Entity (Ada_Root);

yoogx's avatar
yoogx committed
319
         Visit_Subcomponents_Of (E);
320 321 322 323 324 325 326 327 328 329 330 331 332

         Pop_Entity; --  Ada_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);
      begin
         case P is
333 334 335 336 337 338
            when Thread_Periodic |
              Thread_Sporadic    |
              Thread_Hybrid      |
              Thread_Aperiodic   |
              Thread_Background  |
              Thread_ISR         =>
339
               Add_With_Package
340
                 (E            => RU (RU_PolyORB_HI_Generated_Activity, False),
341 342 343 344 345 346 347
                  Used         => False,
                  Warnings_Off => True,
                  Elaborated   => True);

               if P = Thread_Hybrid then
                  Has_Hybrid_Threads := True;
               end if;
348 349 350 351 352 353 354

               declare
                  Initialize_Entrypoint : constant Name_Id :=
                    Get_Thread_Initialize_Entrypoint (E);
                  N : Node_Id;
               begin
                  if Initialize_Entrypoint /= No_Name then
355 356 357 358 359 360 361 362
                     N :=
                       Message_Comment
                         ("Initialize thread " &
                          Get_Name_String
                            (Name
                               (Identifier
                                  (Corresponding_Instance
                                     (Parent_Subcomponent (E))))));
363 364 365

                     Append_Node_To_List (N, ADN.Statements (Current_Package));

366 367 368 369 370
                     N :=
                       Make_Subprogram_Call
                         (Map_Ada_Subprogram_Identifier
                            (Initialize_Entrypoint),
                          No_List);
371 372 373 374
                     Append_Node_To_List (N, ADN.Statements (Current_Package));
                  end if;
               end;

375 376 377 378 379 380 381 382
            when others =>
               raise Program_Error;
         end case;
      end Visit_Thread_Instance;

   end Subprogram_Body;

end Ocarina.Backends.PO_HI_Ada.Main;