ocarina-backends-po_hi_ada-naming.adb 22.2 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-2018 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
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;
yoogx's avatar
yoogx committed
50
with Ocarina.AADL_Values;
51
52
53

package body Ocarina.Backends.PO_HI_Ada.Naming is

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

   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
         end if;

yoogx's avatar
yoogx committed
190
         if Port_Number = Ocarina.AADL_Values.No_Value then
191
192
193
194
195
            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
yoogx's avatar
yoogx committed
394
395
396
                     --  For default transport API, the configuration
                     --  is captured at the level of the process

397
                     N := Naming_Information (Corresponding_Instance (S));
398
399
400
                     Append_Node_To_List (N, Naming_Table_List);

                  elsif Transport_API = Transport_User
yoogx's avatar
yoogx committed
401
402
                    and then AAU.Is_Process (Corresponding_Instance (S))
                    and then Is_Added (Corresponding_Instance (S), Bus, E)
403
                  then
yoogx's avatar
yoogx committed
404
405
406
407
408
409
410
411
412
                     --  For user-defined transport, the configuration
                     --  is captured in the device that supports the
                     --  communication

                     N := Naming_Information
                       (Corresponding_Instance
                          (Get_Device_Of_Process
                             (Bus, Corresponding_Instance (S))));

413
414
415
416
417
418
                     Append_Node_To_List (N, Naming_Table_List);
                  end if;

                  S := Next_Node (S);
               end loop;

419
420
421
422
423
424
425
426
427
428
429
               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))));
430
431
               Append_Node_To_List (N, Naming_Table_List);

432
433
               --  Declare the Naming Table

434
435
436
437
438
               N :=
                 Message_Comment
                   ("Naming Table for bus " &
                    Get_Name_String
                      (Name (Identifier (Parent_Subcomponent (Bus)))));
439
440
441
442
443
               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

444
445
446
447
448
449
                  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));
450
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
451

452
453
454
               else
                  --  We generate the default name table

455
456
457
458
459
460
461
                  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));
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
                  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
485
         U : constant Node_Id :=
486
           ADN.Distributed_Application_Unit
487
488
489
490
491
492
493
494
495
496
497
             (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;
498
499
500
501
502
503
504
505
506
507
508
509
510
511
         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));

512
513
         Main_Loop :
         while Present (S) loop
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
            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
545
546
                                      (Corresponding_Instance (S),
                                       E);
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
594
595
596
597
598
599
600
601
602
603
604
                                    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
605
         Visit_Subcomponents_Of (E);
606
607
608
609
610
611
612

         Pop_Entity; --  Ada_Root
      end Visit_System_Instance;

   end Package_Spec;

end Ocarina.Backends.PO_HI_Ada.Naming;