ocarina-backends-po_hi_ada-naming.adb 21.8 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 . N A M I N G     --
--                                                                          --
--                                 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 31
--                                                                          --
------------------------------------------------------------------------------

32
with Ocarina.Namet;
33 34 35 36 37 38

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;

39 40
with Ocarina.Instances.Queries;

41 42 43 44 45 46 47 48 49 50 51 52
with Ocarina.Backends.Utils;
with Ocarina.Backends.Properties;
with Ocarina.Backends.Messages;
with Ocarina.Backends.PO_HI_Ada.Mapping;
with Ocarina.Backends.PO_HI_Ada.Runtime;
with Ocarina.Backends.Ada_Tree.Nutils;
with Ocarina.Backends.Ada_Tree.Nodes;

with Ocarina.Backends.Ada_Values;

package body Ocarina.Backends.PO_HI_Ada.Naming is

53
   use Ocarina.Namet;
54 55 56 57 58 59 60 61 62 63
   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.Messages;
   use Ocarina.Backends.PO_HI_Ada.Mapping;
   use Ocarina.Backends.PO_HI_Ada.Runtime;
   use Ocarina.Backends.Ada_Tree.Nutils;
   use Ocarina.Backends.Ada_Values;
64
   use Ocarina.Instances.Queries;
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79

   package ADV renames Ocarina.Backends.Ada_Values;
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
   package ADN renames Ocarina.Backends.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);
yoogx's avatar
yoogx committed
80
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
81 82

      function Added_Internal_Name
83 84 85 86
        (P : Node_Id;
         B : Node_Id;
         E : Node_Id) return Name_Id;
      function Is_Added (P : Node_Id; B : Node_Id; E : Node_Id) return Boolean;
87 88 89 90 91 92 93 94 95 96 97 98 99 100
      procedure Set_Added (P : Node_Id; B : Node_Id; E : Node_Id);
      --  Used to ensure that the naming information are added only
      --  for the nodes connected to a particular node.

      function 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.

      -------------------------
      -- Added_Internal_Name --
      -------------------------

      function Added_Internal_Name
101 102 103 104
        (P : Node_Id;
         B : Node_Id;
         E : Node_Id) return Name_Id
      is
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
      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 (B));
         Add_Char_To_Name_Buffer ('%');
         Add_Nat_To_Name_Buffer (Nat (E));

         return Name_Find;
      end Added_Internal_Name;

      --------------
      -- Is_Added --
      --------------

      function Is_Added
121 122 123 124
        (P : Node_Id;
         B : Node_Id;
         E : Node_Id) return Boolean
      is
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
         I_Name : constant Name_Id := Added_Internal_Name (P, B, E);
      begin
         return Get_Name_Table_Byte (I_Name) = 1;
      end Is_Added;

      ---------------
      -- Set_Added --
      ---------------

      procedure Set_Added (P : Node_Id; B : Node_Id; E : Node_Id) is
         I_Name : constant Name_Id := Added_Internal_Name (P, B, E);
      begin
         Set_Name_Table_Byte (I_Name, 1);
      end Set_Added;

      ------------------------
      -- Naming_Information --
      ------------------------

      function Naming_Information (E : Node_Id) return Node_Id is
145 146 147 148 149 150
         Location           : Name_Id;
         Port_Number        : Value_Id;
         N                  : Node_Id;
         L                  : Node_Id;
         P                  : Node_Id;
         V                  : Node_Id;
151 152
         Configuration_Data : Name_Id := No_Name;

153 154
      begin
         if AAU.Is_Process (E) then
155
            Location    := Get_Location (Get_Bound_Processor (E));
156
            Port_Number := Get_Port_Number (E);
157

158
         elsif AAU.Is_Device (E) then
159 160
            Location           := Get_Location (E);
            Port_Number        := Get_Port_Number (E);
161
            Configuration_Data := Get_Type_Source_Name (E);
162 163 164
         end if;

         if Location = No_Name then
165
            if Is_Defined_Property (E, "deployment::configuration")
166 167 168
              and then
                Get_String_Property (E, "deployment::configuration") /=
                No_Name
169 170
            then
               Get_Name_String
171 172 173 174 175 176
                 (Get_String_Property (E, "deployment::configuration"));
               L :=
                 Make_Subprogram_Call
                   (RE (RE_To_HI_String),
                    Make_List_Id
                      (Make_Literal (New_String_Value (Name_Find))));
177
            else
178 179 180 181
               L :=
                 Make_Subprogram_Call
                   (RE (RE_To_HI_String),
                    Make_List_Id (Make_Literal (New_String_Value (No_Name))));
182
            end if;
183
         else
184 185 186 187
            L :=
              Make_Subprogram_Call
                (RE (RE_To_HI_String),
                 Make_List_Id (Make_Literal (New_String_Value (Location))));
188 189 190 191 192 193 194 195
         end if;

         if Port_Number = ADV.No_Value then
            P := Make_Literal (New_Integer_Value (0, 1, 10));
         else
            P := Make_Literal (To_Ada_Value (Port_Number));
         end if;

196 197 198
         if Configuration_Data = No_Name then
            V := RE (RE_Null_Address);
         else
199 200 201 202
            V :=
              Make_Attribute_Designator
                (Map_Ada_Subprogram_Identifier (Configuration_Data),
                 A_Address);
203 204
         end if;

205 206
         --  Build the record aggregate

207
         N := Make_Record_Aggregate (Make_List_Id (L, P, V));
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
         N := Make_Element_Association (Extract_Enumerator (E), N);
         return N;
      end 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
244 245
         Category : constant Component_Category :=
           Get_Category_Of_Component (E);
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274
      begin
         case Category 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_Bus_Instance --
      ------------------------

      procedure Visit_Bus_Instance (Bus : Node_Id; E : Node_Id);

      procedure Visit_Bus_Instance (Bus : Node_Id; E : Node_Id) is
         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);
275 276 277
         Root_Sys          : constant Node_Id :=
           Parent_Component (Parent_Subcomponent (E));
         Transport_API : Supported_Transport_APIs := Transport_None;
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
      begin
         --  We perform a first loop to designate the nodes to be
         --  included in the naming table. For a particular node, the
         --  nodes 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) Add current process E to the naming table

         if Is_Added (E, Bus, E) then
            return;
         end if;

         Set_Added (E, Bus, E);

         --  (2) Add other processes connected to E

         if not AAU.Is_Empty (Features (E)) then
            F := First_Node (Features (E));

            while Present (F) loop
               --  We make two iterations to traverse (1) the sources
               --  of F then (2) the destinations of F.

               End_List := Sources (F);

               for J in 1 .. 2 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 AAU.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, Bus, E);
                           end if;

                           --  Get the connection involving C_End

                           C := Extra_Item (C_End);
                           pragma Assert (Present (C));

                           --  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 their
                           --  connections.

338 339
                           if Transport_API /= Transport_None
                             and then Transport_API /= Get_Transport_API (B, E)
340 341 342
                           then
                              Display_Located_Error
                                (Loc (Parent_Subcomponent (E)),
343 344 345 346
                                 "The features of this process are involved" &
                                 " in connections that do not use the same" &
                                 " transport layer. This is not supported" &
                                 " yet.",
347 348 349 350 351 352 353 354 355 356 357
                                 Fatal => True);
                           else
                              Transport_API := Get_Transport_API (B, E);

                              --  If we have a bus for which no
                              --  transport layer has been specified,
                              --  we raise an error.

                              if Transport_API = Transport_None then
                                 Display_Located_Error
                                   (Loc (B),
358 359
                                    "No transport layer has been specified" &
                                    " for this bus",
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
                                    Fatal => True);
                              end if;
                           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;

         --  Generate the naming table

         case Transport_API is
382
            when Transport_BSD_Sockets | Transport_User =>
383 384 385 386 387 388 389 390 391 392 393
               --  Build the node information for all the nodes
               --  involved with the current one and append it to the
               --  naming list.

               S := First_Node (Subcomponents (Root_Sys));

               while Present (S) loop
                  if Transport_API = Transport_BSD_Sockets
                    and then AAU.Is_Process (Corresponding_Instance (S))
                    and then Is_Added (Corresponding_Instance (S), Bus, E)
                  then
394
                     N := Naming_Information (Corresponding_Instance (S));
395 396 397 398 399 400
                     Append_Node_To_List (N, Naming_Table_List);

                  elsif Transport_API = Transport_User
                    and then AAU.Is_Device (Corresponding_Instance (S))
                    and then Is_Connected (Bus, S)
                  then
401
                     N := Naming_Information (Corresponding_Instance (S));
402 403 404 405 406 407
                     Append_Node_To_List (N, Naming_Table_List);
                  end if;

                  S := Next_Node (S);
               end loop;

408 409 410 411 412 413 414 415 416 417 418
               N :=
                 Make_Element_Association
                   (No_Node,
                    Make_Record_Aggregate
                      (Make_List_Id
                         (Make_Subprogram_Call
                            (RE (RE_To_HI_String),
                             Make_List_Id
                               (Make_Literal (New_String_Value (No_Name)))),
                          Make_Literal (New_Integer_Value (0, 1, 10)),
                          RE (RE_Null_Address))));
419 420
               Append_Node_To_List (N, Naming_Table_List);

421 422
               --  Declare the Naming Table

423 424 425 426 427
               N :=
                 Message_Comment
                   ("Naming Table for bus " &
                    Get_Name_String
                      (Name (Identifier (Parent_Subcomponent (Bus)))));
428 429 430 431 432
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));

               if Transport_API = Transport_User then
                  --  We are building a name table specific to a bus

433 434 435 436 437 438
                  N :=
                    Make_Object_Declaration
                      (Defining_Identifier => Map_Bus_Name (Bus),
                       Constant_Present    => True,
                       Object_Definition   => RE (RE_Naming_Table_Type),
                       Expression => Make_Array_Aggregate (Naming_Table_List));
439
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
440

441 442 443
               else
                  --  We generate the default name table

444 445 446 447 448 449 450
                  N :=
                    Make_Object_Declaration
                      (Defining_Identifier =>
                         Make_Defining_Identifier (PN (P_Naming_Table)),
                       Constant_Present  => True,
                       Object_Definition => RE (RE_Naming_Table_Type),
                       Expression => Make_Array_Aggregate (Naming_Table_List));
451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
               end if;

            when Transport_SpaceWire =>
               Display_Located_Error
                 (Loc (E),
                  "SpaceWire bus is no longer supported",
                  Fatal => True);

            when Transport_None =>
               --  If we did not fetch a meaningful transport layer,
               --  this means the application does not use the
               --  network. No naming table will be generated.

               null;
         end case;
      end Visit_Bus_Instance;

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

      procedure Visit_Process_Instance (E : Node_Id) is
474
         U : constant Node_Id :=
475
           ADN.Distributed_Application_Unit
476 477 478 479 480 481 482 483 484 485 486
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
         P        : constant Node_Id := ADN.Entity (U);
         S        : Node_Id;
         Parent   : Node_Id;
         Root_Sys : constant Node_Id :=
           Parent_Component (Parent_Subcomponent (E));
         F         : Node_Id;
         B         : Node_Id;
         C         : Node_Id;
         C_End     : Node_Id;
         End_List  : List_Id;
487 488 489 490 491 492 493 494 495 496 497 498 499 500
         Transport : Supported_Transport_APIs;

      begin
         pragma Assert (AAU.Is_System (Root_Sys));
         Push_Entity (P);
         Push_Entity (U);
         Set_Naming_Spec;

         --  We go through all bus

         Transport := Transport_None;

         S := First_Node (Subcomponents (Root_Sys));

501 502
         Main_Loop :
         while Present (S) loop
503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
            if AAU.Is_Bus (Corresponding_Instance (S)) then
               if not AAU.Is_Empty (Features (E)) then
                  F := First_Node (Features (E));

                  while Present (F) loop
                     --  We make two iterations to traverse (1) the
                     --  sources of F then (2) the destinations of F.

                     End_List := Sources (F);
                     for J in 1 .. 2 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 AAU.Is_Process (Parent) then
                                 --  Get the connection involving C_End

                                 C := Extra_Item (C_End);
                                 pragma Assert (Present (C));

                                 --  Get the bus of the connection

                                 B := Get_Bound_Bus (C);

                                 Transport := Get_Transport_API (B);

                                 if Present (B)
                                   and then B = Corresponding_Instance (S)
                                 then
                                    Visit_Bus_Instance
534 535
                                      (Corresponding_Instance (S),
                                       E);
536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
                                    if Transport /= Transport_User
                                      and then Transport /= Transport_None
                                    then
                                       exit Main_Loop;
                                    end if;
                                 end if;
                              end if;
                              C_End := Next_Node (C_End);
                           end loop;

                           --  In the next iteration, we traverse the
                           --  Destinations of F.

                           End_List := Destinations (F);

                        end if;
                     end loop;

                     F := Next_Node (F);
                  end loop;
               end if;
            end if;
            S := Next_Node (S);

         end loop Main_Loop;

         Bind_Transport_API (E, Transport);
         --  XXX dubious. Actually, it is used only through
         --  Fetch_Transport_API to run Transport_API initialization
         --  in main thread.

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

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

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

         --  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

yoogx's avatar
yoogx committed
594
         Visit_Subcomponents_Of (E);
595 596 597 598 599 600 601

         Pop_Entity; --  Ada_Root
      end Visit_System_Instance;

   end Package_Spec;

end Ocarina.Backends.PO_HI_Ada.Naming;