OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--       O C A R I N A . B A C K E N D S . P O _ H I _ A D A . J O B        --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                    Copyright (C) 2019-2020 OpenAADL                      --
10
--                                                                          --
11
-- Ocarina  is free software; you can redistribute it and/or modify under   --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion. Ocarina is distributed in the hope that it will be useful, but     --
15
-- WITHOUT ANY WARRANTY; without even the implied warranty of               --
16
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
--                    Ocarina is maintained by OpenAADL team                --
28
--                              (info@openaadl.org)                         --
29
--                                                                          --
30
------------------------------------------------------------------------------
31

32
with Ocarina.Namet;
33
with Locations;
34

35
with Ocarina.ME_AADL;
36
with Ocarina.ME_AADL.AADL_Tree.Nodes;
37
with Ocarina.ME_AADL.AADL_Instances.Nodes;
38
with Ocarina.ME_AADL.AADL_Instances.Nutils;
39
with Ocarina.ME_AADL.AADL_Instances.Entities;
40

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

50 1
package body Ocarina.Backends.PO_HI_Ada.Job is
51

52
   use Ocarina.Namet;
53
   use Locations;
54
   use Ocarina.ME_AADL;
55
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
56
   use Ocarina.ME_AADL.AADL_Instances.Entities;
57
   use Ocarina.Backends.Utils;
58
   use Ocarina.Backends.Properties;
59
   use Ocarina.Backends.Messages;
60
   use Ocarina.Backends.Ada_Tree.Nutils;
61
   use Ocarina.Backends.Ada_Values;
62
   use Ocarina.Backends.PO_HI_Ada.Mapping;
63
   use Ocarina.Backends.PO_HI_Ada.Runtime;
64

65
   package AAN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
66
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
67
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
68
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
69
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
70
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
71

72
   function Get_Fully_Qualified_Subprogram (S : Name_Id) return Node_Id;
73
   --  Return an identifier to S whose parent unit name is the
74
   --  instantiated package correspodning to the interface of E.
75

76
   ------------------------------------
77
   -- Get_Fully_Qualified_Subprogram --
78
   ------------------------------------
79

80 1
   function Get_Fully_Qualified_Subprogram
81
     (S : Name_Id) return Node_Id
82
   is
83
      P : constant Node_Id :=
84 1
        RU (RU_PolyORB_HI_Generated_Activity);
85 1
      N : constant Node_Id := Make_Defining_Identifier (S);
86
   begin
87 1
      Set_Homogeneous_Parent_Unit_Name (N, P);
88

89 1
      return N;
90
   end Get_Fully_Qualified_Subprogram;
91

92
   ------------------
93
   -- Package_Spec --
94
   ------------------
95

96
   package body Package_Spec is
97

98
      procedure Visit_Architecture_Instance (E : Node_Id);
99
      procedure Visit_Component_Instance (E : Node_Id);
100
      procedure Visit_System_Instance (E : Node_Id);
101
      procedure Visit_Process_Instance (E : Node_Id);
102
      procedure Visit_Thread_Instance (E : Node_Id);
103
      procedure Visit_Device_Instance (E : Node_Id);
104
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
105

106
      procedure Cyclic_Task_Instantiation_Formals
107
        (E      : Node_Id;
108
         P_List : List_Id);
109
      --  Appends the formal generic parameter association which are
110
      --  common between periodic and sporadic tasks.
111

112
      function Periodic_Task_Instantiation (E : Node_Id) return Node_Id;
113
      --  Build a package instantiation for a periodic task
114

115
      function Sporadic_Task_Instantiation (E : Node_Id) return Node_Id;
116
      --  Build a package instantiation for a sporadic task
117

118
      function Aperiodic_Task_Instantiation (E : Node_Id) return Node_Id;
119
      --  Build a package instantiation for an aperiodic task
120

121
      function Hybrid_Task_Instantiation (E : Node_Id) return Node_Id;
122
      --  Build a package instantiation for a hybrid task
123

124
      function Background_Task_Instantiation (E : Node_Id) return Node_Id;
125
      --  Build a package instantiation for a background task
126

127
      function Null_Task_Instantiation (E : Node_Id) return Node_Id;
128
      --  Build a package instantiation for a null task
129

130
      function ISR_Task_Instantiation (E : Node_Id) return Node_Id;
131
      --  Build a package instantiation for a background task
132

133
      function Task_Job_Spec (E : Node_Id) return Node_Id;
134
      --  Creates the parameterless subprogram specification that does
135
      --  the thread's job.
136

137
      function Make_Mode_Updater_Spec (E : Node_Id) return Node_Id;
138
      --  Create the procedure which will update the current mode
139

140
      function Make_Modes_Enumeration (E : Node_Id) return Node_Id;
141
      --  Create the mode enumeration
142

143
      ---------------------------------------
144
      -- Cyclic_Task_Instantiation_Formals --
145
      ---------------------------------------
146

147 1
      procedure Cyclic_Task_Instantiation_Formals
148
        (E      : Node_Id;
149
         P_List : List_Id)
150
      is
151 1
         N : Node_Id;
152 1
         I : Unsigned_Long_Long;
153 1
         T : Time_Type;
154

155
      begin
156
         --  The entity name
157

158
         N :=
159 1
           Make_Parameter_Association
160 1
             (Selector_Name    => Make_Defining_Identifier (PN (P_Entity)),
161 1
              Actual_Parameter => Extract_Enumerator (E));
162 1
         Append_Node_To_List (N, P_List);
163

164 1
         if Get_Thread_Dispatch_Protocol (E) = Thread_Periodic
165 1
           or else Get_Thread_Dispatch_Protocol (E) = Thread_Sporadic
166 1
           or else Get_Thread_Dispatch_Protocol (E) = Thread_Hybrid
167 1
           or else Get_Thread_Dispatch_Protocol (E) = Thread_ISR
168
         then
169
            --  The task period of minimal interarrival time
170

171
            N :=
172 1
              Make_Parameter_Association
173
                (Selector_Name =>
174 1
                   Make_Defining_Identifier (PN (P_Task_Period)),
175 1
                 Actual_Parameter => Map_Ada_Time (Get_Thread_Period (E)));
176 1
            Append_Node_To_List (N, P_List);
177

178
            --  The task deadline
179

180 1
            N := Map_Ada_Time (Get_Thread_Deadline (E));
181

182
            N :=
183 1
              Make_Parameter_Association
184
                (Selector_Name =>
185 1
                   Make_Defining_Identifier (PN (P_Task_Deadline)),
186
                 Actual_Parameter => N);
187 1
            Append_Node_To_List (N, P_List);
188
         end if;
189

190 1
         if Get_Thread_Dispatch_Protocol (E) = Thread_Periodic then
191
            --  The dispatch offset
192 1
            T := Get_Dispatch_Offset (E);
193

194 1
            if T /= Null_Time then
195
               N :=
196 1
                 Make_Parameter_Association
197
                   (Selector_Name =>
198 1
                      Make_Defining_Identifier (PN (P_Dispatch_Offset)),
199 1
                    Actual_Parameter => Map_Ada_Time (T));
200 1
               Append_Node_To_List (N, P_List);
201
            end if;
202
         end if;
203

204
         --  The task priority, if the thread has no priority, we
205
         --  assign a default one.
206

207 1
         I := Get_Thread_Priority (E);
208

209 1
         if I = 0 then
210 1
            N := RE (RE_Default_Priority);
211
         else
212 1
            N := Map_Ada_Priority (I);
213
         end if;
214

215
         N :=
216 1
           Make_Parameter_Association
217 1
             (Selector_Name => Make_Defining_Identifier (PN (P_Task_Priority)),
218
              Actual_Parameter => N);
219 1
         Append_Node_To_List (N, P_List);
220

221
         --  The task stack size, if the thread has no stack size, we
222
         --  assign a default one.
223

224 1
         I := To_Bytes (Get_Thread_Stack_Size (E));
225

226 1
         if I = 0 then
227
            --  The default stack size is 100 Kb
228

229 1
            N := Make_Literal (New_Integer_Value (100_000, 1, 10));
230
         else
231 1
            N := Make_Literal (New_Integer_Value (I, 1, 10));
232
         end if;
233

234
         N :=
235 1
           Make_Parameter_Association
236
             (Selector_Name =>
237 1
                Make_Defining_Identifier (PN (P_Task_Stack_Size)),
238
              Actual_Parameter => N);
239 1
         Append_Node_To_List (N, P_List);
240

241
         --  The task job
242

243
         N :=
244 1
           Make_Parameter_Association
245 1
             (Selector_Name    => Make_Defining_Identifier (PN (P_Job)),
246 1
              Actual_Parameter => Map_Task_Job_Identifier (E));
247 1
         Append_Node_To_List (N, P_List);
248

249
         --  If an activate entrypoint has been specified for the
250
         --  thread, add an additional parameter association
251

252
         declare
253
            Activate_Entrypoint : constant Name_Id :=
254 1
              Get_Thread_Activate_Entrypoint (E);
255
         begin
256 1
            if Activate_Entrypoint /= No_Name then
257
               --  We cannot use direcly the activate entrypoint
258
               --  because the Activity spec must not depend on user
259
               --  package specs (to avoid introducing elaboration
260
               --  cycles). We use subprogram renaming as workaround.
261

262
               N :=
263 1
                 Make_Subprogram_Specification
264 1
                   (Defining_Identifier => Map_Task_Init_Identifier (E),
265
                    Parameter_Profile   => No_List,
266
                    Return_Type         => No_Node);
267 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
268

269
               N :=
270 1
                 Make_Parameter_Association
271
                   (Selector_Name =>
272 1
                      Make_Defining_Identifier (PN (P_Activate_Entrypoint)),
273 1
                    Actual_Parameter => Map_Task_Init_Identifier (E));
274 1
               Append_Node_To_List (N, P_List);
275
            end if;
276
         end;
277

278
         --  If a recover entrypoint has been specified for the
279
         --  thread, add an additional parameter association
280

281
         declare
282
            Rec_Entrypoint : constant Name_Id :=
283 1
              Get_Thread_Recover_Entrypoint (E);
284
         begin
285 1
            if Rec_Entrypoint /= No_Name then
286
               --  We cannot use direcly the recover entrypoint
287
               --  because the Activity spec must not depend on user
288
               --  package specs (to avoid introducing elaboration
289
               --  cycles). We use subprogram renaminng as workaround.
290

291
               N :=
292 1
                 Make_Subprogram_Specification
293 1
                   (Defining_Identifier => Map_Task_Recover_Identifier (E),
294
                    Parameter_Profile   => No_List,
295
                    Return_Type         => No_Node);
296 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
297

298
               N :=
299 1
                 Make_Parameter_Association
300
                   (Selector_Name =>
301 1
                      Make_Defining_Identifier (PN (P_Recover_Entrypoint)),
302 1
                    Actual_Parameter => Map_Task_Recover_Identifier (E));
303 1
               Append_Node_To_List (N, P_List);
304
            end if;
305
         end;
306 1
      end Cyclic_Task_Instantiation_Formals;
307

308
      ---------------------------------
309
      -- Periodic_Task_Instantiation --
310
      ---------------------------------
311

312 1
      function Periodic_Task_Instantiation (E : Node_Id) return Node_Id is
313 1
         N              : Node_Id;
314
         Parameter_List : constant List_Id :=
315 1
           New_List (ADN.K_Parameter_Profile);
316
      begin
317
         --  Build the common parameters
318

319 1
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
320

321
         --  Build the package instantiation
322

323
         N :=
324 1
           Make_Package_Instantiation
325 1
             (Defining_Identifier => Map_Task_Identifier (E),
326
              Generic_Package     =>
327 1
                RU (RU_PolyORB_HI_Periodic_Task, Elaborated => True),
328
              Parameter_List => Parameter_List);
329 1
         return N;
330
      end Periodic_Task_Instantiation;
331

332
      ---------------------------------
333
      -- Sporadic_Task_Instantiation --
334
      ---------------------------------
335

336 1
      function Sporadic_Task_Instantiation (E : Node_Id) return Node_Id is
337 1
         N              : Node_Id;
338 1
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
339
      begin
340
         --  Port_Type
341

342
         N :=
343 1
           Make_Parameter_Association
344 1
             (Selector_Name    => Make_Defining_Identifier (TN (T_Port_Type)),
345
              Actual_Parameter =>
346 1
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)));
347 1
         Append_Node_To_List (N, Parameter_List);
348

349
         --  Raise an error if the thread does not have IN ports
350

351 1
         if not Has_In_Ports (E) then
352 0
            Display_Located_Error
353 0
              (Loc (E),
354
               "This sporadic thread does not have IN ports",
355
               Fatal => True);
356
         end if;
357

358
         --  Raise an error if the thread does not have 'in event'
359
         --  ports.
360

361 1
         if not Has_In_Event_Ports (E) then
362 0
            Display_Located_Error
363 0
              (Loc (E),
364
               "None of the IN ports of this sporadic thread is an event port",
365
               Fatal => True);
366
         end if;
367

368
         --  Append the common parameters
369

370 1
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
371

372
         --  The blocking routine
373

374
         N :=
375 1
           Make_Parameter_Association
376
             (Selector_Name =>
377 1
                Make_Defining_Identifier (SN (S_Wait_For_Incoming_Events)),
378
              Actual_Parameter =>
379 1
                Get_Fully_Qualified_Subprogram
380
                  (SN (S_Wait_For_Incoming_Events)));
381 1
         Append_Node_To_List (N, Parameter_List);
382

383
         --  Build the package instantiation
384

385
         N :=
386 1
           Make_Package_Instantiation
387 1
             (Defining_Identifier => Map_Task_Identifier (E),
388
              Generic_Package     =>
389 1
                RU (RU_PolyORB_HI_Sporadic_Task, Elaborated => True),
390
              Parameter_List => Parameter_List);
391 1
         return N;
392
      end Sporadic_Task_Instantiation;
393

394
      ----------------------------------
395
      -- Aperiodic_Task_Instantiation --
396
      ----------------------------------
397

398 0
      function Aperiodic_Task_Instantiation (E : Node_Id) return Node_Id is
399 0
         N              : Node_Id;
400 0
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
401
      begin
402
         --  Port_Type
403

404
         N :=
405 0
           Make_Parameter_Association
406 0
             (Selector_Name    => Make_Defining_Identifier (TN (T_Port_Type)),
407
              Actual_Parameter =>
408 0
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)));
409 0
         Append_Node_To_List (N, Parameter_List);
410

411
         --  Raise an error if the thread does not have IN ports
412

413 0
         if not Has_In_Ports (E) then
414 0
            Display_Located_Error
415 0
              (Loc (E),
416
               "This sporadic thread does not have IN ports",
417
               Fatal => True);
418
         end if;
419

420
         --  Raise an error if the thread has no 'in event' ports
421

422 0
         if not Has_In_Event_Ports (E) then
423 0
            Display_Located_Error
424 0
              (Loc (E),
425
               "None of the IN ports of this thread is an event port",
426
               Fatal => True);
427
         end if;
428

429
         --  Append the common parameters
430

431 0
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
432

433
         --  The blocking routine
434

435
         N :=
436 0
           Make_Parameter_Association
437
             (Selector_Name =>
438 0
                Make_Defining_Identifier (SN (S_Wait_For_Incoming_Events)),
439
              Actual_Parameter =>
440 0
                Make_Defining_Identifier (SN (S_Wait_For_Incoming_Events)));
441 0
         Append_Node_To_List (N, Parameter_List);
442

443
         --  Build the package instantiation
444

445
         N :=
446 0
           Make_Package_Instantiation
447 0
             (Defining_Identifier => Map_Task_Identifier (E),
448
              Generic_Package     =>
449 0
                RU (RU_PolyORB_HI_Aperiodic_Task, Elaborated => True),
450
              Parameter_List => Parameter_List);
451 0
         return N;
452
      end Aperiodic_Task_Instantiation;
453

454
      -----------------------------------
455
      -- Background_Task_Instantiation --
456
      -----------------------------------
457

458 1
      function Background_Task_Instantiation (E : Node_Id) return Node_Id is
459 1
         N              : Node_Id;
460 1
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
461
      begin
462
         --  Append the common parameters
463

464 1
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
465

466
         --  Build the package instantiation
467

468
         N :=
469 1
           Make_Package_Instantiation
470 1
             (Defining_Identifier => Map_Task_Identifier (E),
471
              Generic_Package     =>
472 1
                RU (RU_PolyORB_HI_Background_Task, Elaborated => True),
473
              Parameter_List => Parameter_List);
474 1
         return N;
475
      end Background_Task_Instantiation;
476

477
      -----------------------------
478
      -- Null_Task_Instantiation --
479
      -----------------------------
480

481 0
      function Null_Task_Instantiation (E : Node_Id) return Node_Id is
482 0
         N              : Node_Id;
483 0
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
484
      begin
485
         --  Append the common parameters
486

487 0
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
488

489
         --  Build the package instantiation
490

491
         N :=
492 0
           Make_Package_Instantiation
493 0
             (Defining_Identifier => Map_Task_Identifier (E),
494 0
              Generic_Package     => RU (RU_PolyORB_HI_Null_Task),
495
              Parameter_List      => Parameter_List);
496 0
         return N;
497
      end Null_Task_Instantiation;
498

499
      ----------------------------
500
      -- ISR_Task_Instantiation --
501
      ----------------------------
502

503 0
      function ISR_Task_Instantiation (E : Node_Id) return Node_Id is
504 0
         N              : Node_Id;
505 0
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
506 0
         Configuration  : Name_Id;
507
      begin
508 0
         Configuration := Get_Configuration (E);
509 0
         if Configuration = No_Name then
510 0
            Display_Located_Error
511 0
              (Loc (E),
512
               "No interrupt configured",
513
               Fatal => True);
514
         end if;
515

516 0
         Add_With_Package (RU (RU_Ada_Interrupts_Names));
517

518
         N :=
519 0
           Make_Parameter_Association
520
             (Selector_Name =>
521 0
                Make_Defining_Identifier (PN (P_Interrupt_Identifier)),
522
              Actual_Parameter =>
523 0
                Make_Defining_Identifier (Get_Configuration (E)));
524 0
         Append_Node_To_List (N, Parameter_List);
525

526
         --  Append the common parameters
527

528 0
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
529

530
         --  Build the package instantiation
531

532
         N :=
533 0
           Make_Package_Instantiation
534 0
             (Defining_Identifier => Map_Task_Identifier (E),
535 0
              Generic_Package     => RU (RU_PolyORB_HI_ISR_Task),
536
              Parameter_List      => Parameter_List);
537 0
         return N;
538
      end ISR_Task_Instantiation;
539

540
      -------------------------------
541
      -- Hybrid_Task_Instantiation --
542
      -------------------------------
543

544 1
      function Hybrid_Task_Instantiation (E : Node_Id) return Node_Id is
545 1
         N              : Node_Id;
546 1
         Parameter_List : constant List_Id := New_List (ADN.K_List_Id);
547
      begin
548
         --  Port_Type
549

550
         N :=
551 1
           Make_Parameter_Association
552 1
             (Selector_Name    => Make_Defining_Identifier (TN (T_Port_Type)),
553
              Actual_Parameter =>
554 1
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)));
555 1
         Append_Node_To_List (N, Parameter_List);
556

557
         --  Raise an error if the thread does not have IN ports
558

559 1
         if not Has_In_Ports (E) then
560 0
            Display_Located_Error
561 0
              (Loc (E),
562
               "This hybrid thread does not have IN ports",
563
               Fatal => True);
564
         end if;
565

566
         --  Raise an error if the thread does not have 'in event'
567
         --  ports.
568

569 1
         if not Has_In_Event_Ports (E) then
570 0
            Display_Located_Error
571 0
              (Loc (E),
572
               "None of the IN ports of this hybrid thread is an event port",
573
               Fatal => True);
574
         end if;
575

576
         --  Append the common parameters
577

578 1
         Cyclic_Task_Instantiation_Formals (E, Parameter_List);
579

580
         --  The blocking routine
581

582
         N :=
583 1
           Make_Parameter_Association
584
             (Selector_Name =>
585 1
                Make_Defining_Identifier (SN (S_Wait_For_Incoming_Events)),
586
              Actual_Parameter =>
587 1
                Get_Fully_Qualified_Subprogram
588
                  (SN (S_Wait_For_Incoming_Events)));
589 1
         Append_Node_To_List (N, Parameter_List);
590

591
         --  Build the package instantiation
592

593
         N :=
594 1
           Make_Package_Instantiation
595 1
             (Defining_Identifier => Map_Task_Identifier (E),
596 1
              Generic_Package     => RU (RU_PolyORB_HI_Hybrid_Task),
597
              Parameter_List      => Parameter_List);
598 1
         return N;
599
      end Hybrid_Task_Instantiation;
600

601
      -------------------
602
      -- Task_Job_Spec --
603
      -------------------
604

605 1
      function Task_Job_Spec (E : Node_Id) return Node_Id is
606 1
         N          : Node_Id;
607 1
         Param_List : List_Id                                     := No_List;
608
         P          : constant Supported_Thread_Dispatch_Protocol :=
609 1
           Get_Thread_Dispatch_Protocol (E);
610
      begin
611 1
         if P = Thread_Sporadic
612 1
           or else P = Thread_Hybrid
613 1
           or else P = Thread_Aperiodic
614
         then
615 1
            Param_List := Make_List_Id
616 1
              (Make_Parameter_Specification
617
                 (Defining_Identifier =>
618 1
                    Make_Defining_Identifier (PN (P_Port)),
619
                  Subtype_Mark        =>
620 1
                    Make_Defining_Identifier (Map_Port_Enumeration_Name (E))),
621 1
               Make_Parameter_Specification
622 1
                 (Defining_Identifier => Make_Defining_Identifier
623
                    (PN (P_Result)),
624 1
                  Subtype_Mark        => RE (RE_Error_Kind),
625
                  Parameter_Mode => Mode_Out));
626

627 1
         elsif P = Thread_Periodic
628 1
           or else P = Thread_Background
629
         then
630 1
            Param_List := Make_List_Id
631 1
              (Make_Parameter_Specification
632 1
                 (Defining_Identifier => Make_Defining_Identifier
633
                    (PN (P_Result)),
634 1
                  Subtype_Mark        => RE (RE_Error_Kind),
635
                  Parameter_Mode => Mode_Out));
636
         end if;
637

638
         N :=
639 1
           Make_Subprogram_Specification
640 1
             (Defining_Identifier => Map_Task_Job_Identifier (E),
641
              Parameter_Profile   => Param_List);
642 1
         return N;
643
      end Task_Job_Spec;
644

645
      -----------
646
      -- Visit --
647
      -----------
648

649 1
      procedure Visit (E : Node_Id) is
650
      begin
651 1
         case Kind (E) is
652 1
            when K_Architecture_Instance =>
653 1
               Visit_Architecture_Instance (E);
654

655 1
            when K_Component_Instance =>
656 1
               Visit_Component_Instance (E);
657

658 0
            when others =>
659 0
               null;
660 1
         end case;
661 1
      end Visit;
662

663
      ---------------------------------
664
      -- Visit_Architecture_Instance --
665
      ---------------------------------
666

667 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
668
      begin
669 1
         Visit (Root_System (E));
670 1
      end Visit_Architecture_Instance;
671

672
      ------------------------------
673
      -- Visit_Component_Instance --
674
      ------------------------------
675

676 1
      procedure Visit_Component_Instance (E : Node_Id) is
677
         Category : constant Component_Category :=
678 1
           Get_Category_Of_Component (E);
679
      begin
680 1
         case Category is
681 1
            when CC_System =>
682 1
               Visit_System_Instance (E);
683

684 1
            when CC_Process =>
685 1
               Visit_Process_Instance (E);
686

687 1
            when CC_Thread =>
688 1
               Visit_Thread_Instance (E);
689

690 1
            when others =>
691 1
               null;
692 1
         end case;
693 1
      end Visit_Component_Instance;
694

695
      ----------------------------
696
      -- Visit_Process_Instance --
697
      ----------------------------
698

699 1
      procedure Visit_Process_Instance (E : Node_Id) is
700
         U : constant Node_Id :=
701 1
           ADN.Distributed_Application_Unit
702 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
703 1
         P                   : constant Node_Id              := ADN.Entity (U);
704 1
         S                   : Node_Id;
705
         Scheduling_Protocol : Supported_Scheduling_Protocol :=
706 1
           Get_Scheduling_Protocol (Get_Bound_Processor (E));
707
         The_System : constant Node_Id :=
708 1
           Parent_Component (Parent_Subcomponent (E));
709

710
      begin
711 1
         Push_Entity (P);
712 1
         Push_Entity (U);
713 1
         Set_Job_Spec;
714

715
         --  Start recording the handling since they have to be reset
716
         --  for each node.
717

718 1
         Start_Recording_Handlings;
719

720 1
         if Scheduling_Protocol = Unknown_Scheduler then
721 1
            Display_Located_Error
722 1
              (Loc (Get_Bound_Processor (E)),
723
               "Undefined scheduling protocol, " &
724
               "will use FIFO_WITHIN_PRIORITIES",
725
               Fatal   => False,
726
               Warning => True);
727

728 1
            Scheduling_Protocol := POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL;
729 1
         elsif Scheduling_Protocol /=
730
           POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL
731 0
           and then Scheduling_Protocol /= ROUND_ROBIN_PROTOCOL
732
         then
733 0
            Display_Located_Error
734 0
              (Loc (Parent_Subcomponent (E)),
735
               "Incompatible scheduling protocol, " &
736
               "PolyORB-HI/Ada runtime requires " &
737
               "POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL or" &
738
               " ROUND_ROBIN_PROTOCOL",
739
               Fatal => True);
740

741
            --  XXX In case of Round robin, we should also check that
742
            --  the scheduler is set to non-preemptive mode.
743
         end if;
744

745
         --  Visit all the subcomponents of the process
746

747 1
         if not AINU.Is_Empty (Subcomponents (E)) then
748 1
            S := First_Node (Subcomponents (E));
749

750 1
            while Present (S) loop
751 1
               Visit (Corresponding_Instance (S));
752

753 1
               S := Next_Node (S);
754 1
            end loop;
755
         end if;
756

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

760 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
761 1
            S := First_Node (Subcomponents (The_System));
762 1
            while Present (S) loop
763 1
               if AAU.Is_Device (Corresponding_Instance (S))
764
                 and then
765 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
766 1
                   Get_Bound_Processor (E)
767
               then
768 1
                  Visit_Device_Instance (Corresponding_Instance (S));
769
               end if;
770 1
               S := Next_Node (S);
771 1
            end loop;
772
         end if;
773

774
         --  Unmark all the marked types
775

776 1
         Reset_Handlings;
777

778 1
         Pop_Entity; -- U
779 1
         Pop_Entity; -- P
780 1
      end Visit_Process_Instance;
781

782
      ---------------------------
783
      -- Visit_Device_Instance --
784
      ---------------------------
785

786 1
      procedure Visit_Device_Instance (E : Node_Id) is
787 1
         Implementation : constant Node_Id := Get_Implementation (E);
788 1
         S              : Node_Id;
789
      begin
790 1
         if Implementation /= No_Node then
791 1
            if not AAU.Is_Empty (AAN.Subcomponents (Implementation)) then
792 1
               S := First_Node (Subcomponents (Implementation));
793 1
               while Present (S) loop
794 1
                  Visit_Component_Instance (Corresponding_Instance (S));
795 1
                  S := Next_Node (S);
796 1
               end loop;
797
            end if;
798
         end if;
799 1
      end Visit_Device_Instance;
800

801
      ---------------------------
802
      -- Visit_System_Instance --
803
      ---------------------------
804

805 1
      procedure Visit_System_Instance (E : Node_Id) is
806
      begin
807 1
         Push_Entity (Ada_Root);
808

809
         --  Visit all the subcomponents of the system
810

811 1
         Visit_Subcomponents_Of (E);
812

813 1
         Pop_Entity; --  Ada_Root
814 1
      end Visit_System_Instance;
815

816
      ---------------------------
817
      -- Visit_Thread_Instance --
818
      ---------------------------
819

820 1
      procedure Visit_Thread_Instance (E : Node_Id) is
821
         P : constant Supported_Thread_Dispatch_Protocol :=
822 1
           Get_Thread_Dispatch_Protocol (E);
823 1
         S : constant Node_Id := Parent_Subcomponent (E);
824 1
         N : Node_Id;
825 1
         O : Node_Id;
826

827 1
         Scheduling_Protocol : Supported_Scheduling_Protocol :=
828
           Unknown_Scheduler;
829 1
         Process_Node : Node_Id;
830

831
      begin
832
         --  Determine the scheduler that controls the current thread instance
833

834 1
         Process_Node := Get_Container_Process (Parent_Subcomponent (E));
835

836 1
         if Present (Process_Node) then
837
            Scheduling_Protocol :=
838 1
              Get_Scheduling_Protocol
839 1
                (Get_Bound_Processor (Corresponding_Instance (Process_Node)));
840
         end if;
841

842 1
         case P is
843 1
            when Thread_Periodic =>
844 1
               N :=
845 1
                 Message_Comment
846 1
                   ("Periodic task : " &
847 1
                    Get_Name_String (Display_Name (Identifier (S))));
848 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
849

850 1
            when Thread_Sporadic =>
851 1
               N :=
852 1
                 Message_Comment
853 1
                   ("Sporadic task : " &
854 1
                    Get_Name_String (Display_Name (Identifier (S))));
855 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
856

857 1
            when Thread_Hybrid =>
858 1
               N :=
859 1
                 Message_Comment
860 1
                   ("Hybrid task : " &
861 1
                    Get_Name_String (Display_Name (Identifier (S))));
862 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
863

864 0
            when Thread_Aperiodic =>
865 0
               N :=
866 0
                 Message_Comment
867 0
                   ("Aperiodic task : " &
868 0
                    Get_Name_String (Display_Name (Identifier (S))));
869 0
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
870

871 1
            when Thread_Background =>
872 1
               N :=
873 1
                 Message_Comment
874 1
                   ("Background task : " &
875 1
                    Get_Name_String (Display_Name (Identifier (S))));
876 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
877

878 0
            when Thread_ISR =>
879 0
               N :=
880 0
                 Message_Comment
881 0
                   ("ISR task : " &
882 0
                    Get_Name_String (Display_Name (Identifier (S))));
883 0
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
884

885 0
            when others =>
886 0
               Display_Located_Error
887 0
                 (AIN.Loc (E),
888
                  "Unsupported dispatch protocol",
889
                  Fatal => True);
890 1
         end case;
891

892
         --  Create the spec of the parameterless subprogram that
893
         --  executes the thread job.
894

895 1
         N := Task_Job_Spec (E);
896 1
         Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
897 1
         Bind_AADL_To_Job (Identifier (S), N);
898

899
         --  For each AADL thread, we instantiate a task.
900

901 1
         if Scheduling_Protocol = ROUND_ROBIN_PROTOCOL then
902 0
            N := Null_Task_Instantiation (E);
903 0
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
904

905
         else
906
            --  Default case : FIFO_WITHIN_PRIORITIES
907 1
            case P is
908 1
               when Thread_Periodic =>
909
                  --  Instantiate the periodic task
910

911 1
                  N := Periodic_Task_Instantiation (E);
912 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
913

914 1
               when Thread_Sporadic =>
915
                  --  Instantiate the sporadic task
916

917 1
                  N := Sporadic_Task_Instantiation (E);
918 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
919

920 1
               when Thread_Hybrid =>
921
                  --  Instantiate the hybrid task
922

923 1
                  N := Hybrid_Task_Instantiation (E);
924 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
925

926 0
               when Thread_Aperiodic =>
927
                  --  Instantiate the aperiodic task
928

929 0
                  N := Aperiodic_Task_Instantiation (E);
930 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
931

932 1
               when Thread_Background =>
933
                  --  Instantiate the background task
934

935 1
                  N := Background_Task_Instantiation (E);
936 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
937

938 0
               when Thread_ISR =>
939
                  --  Instantiate the ISR task
940

941 0
                  N := ISR_Task_Instantiation (E);
942 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
943

944 0
               when others =>
945 0
                  raise Program_Error;
946 1
            end case;
947
         end if;
948

949 1
         if Has_Modes (E) then
950
            --  If the thread has operational modes, then generate the
951
            --  enumeration type corresponding to the thread mode list
952
            --  and the procedure allowing to update the current mode.
953

954 1
            N := Make_Modes_Enumeration (E);
955 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
956

957 1
            if Is_Fusioned (E) then
958 0
               N := Make_Mode_Updater_Spec (E);
959 0
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
960
            end if;
961
         end if;
962

963
         --  Visit thread local objects
964

965 1
         if not AINU.Is_Empty (Subcomponents (E)) then
966 0
            O := First_Node (Subcomponents (E));
967

968 0
            while Present (O) loop
969 0
               if AINU.Is_Data (Corresponding_Instance (O)) then
970
                  N :=
971 0
                    Make_Object_Declaration
972 0
                      (Defining_Identifier => Map_Ada_Defining_Identifier (O),
973
                       Object_Definition   =>
974 0
                         Map_Ada_Data_Type_Designator
975 0
                           (Corresponding_Instance (O)));
976 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
977

978
                  --  Link the variable and the object
979

980 0
                  Bind_AADL_To_Object (Identifier (O), N);
981
               end if;
982

983 0
               O := Next_Node (O);
984 0
            end loop;
985
         end if;
986 1
      end Visit_Thread_Instance;
987

988
      ----------------------------
989
      -- Make_Modes_Enumeration --
990
      ----------------------------
991

992 1
      function Make_Modes_Enumeration (E : Node_Id) return Node_Id is
993 1
         Enum_List : constant List_Id := New_List (ADN.K_Enumeration_Literals);
994 1
         M         : Node_Id;
995 1
         N         : Node_Id;
996
      begin
997 1
         M := First_Node (Modes (E));
998

999 1
         while Present (M) loop
1000 1
            N := Map_Ada_Defining_Identifier (M);
1001 1
            Append_Node_To_List (N, Enum_List);
1002

1003 1
            M := Next_Node (M);
1004 1
         end loop;
1005

1006
         N :=
1007 1
           Make_Full_Type_Declaration
1008
             (Defining_Identifier =>
1009 1
                Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)),
1010 1
              Type_Definition => Make_Enumeration_Type_Definition (Enum_List));
1011

1012 1
         return N;
1013
      end Make_Modes_Enumeration;
1014

1015
      ----------------------------
1016
      -- Make_Mode_Updater_Spec --
1017
      ----------------------------
1018

1019 0
      function Make_Mode_Updater_Spec (E : Node_Id) return Node_Id is
1020 0
         N : Node_Id;
1021
      begin
1022
         N :=
1023 0
           Make_Subprogram_Specification
1024
             (Defining_Identifier =>
1025 0
                Make_Defining_Identifier (SN (S_Change_Mode)),
1026
              Parameter_Profile =>
1027 0
                Make_List_Id
1028 0
                  (Make_Parameter_Specification
1029
                     (Defining_Identifier =>
1030 0
                        Make_Defining_Identifier (PN (P_Mode)),
1031
                      Subtype_Mark =>
1032 0
                        Make_Defining_Identifier
1033 0
                          (Map_Modes_Enumeration_Name (E)),
1034
                      Parameter_Mode => Mode_In)),
1035
              Return_Type => No_Node);
1036 0
         Set_Backend_Node (Identifier (First_Node (Modes (E))), N);
1037

1038 0
         return N;
1039
      end Make_Mode_Updater_Spec;
1040

1041
   end Package_Spec;
1042

1043
   ------------------
1044
   -- Package_Body --
1045
   ------------------
1046

1047
   package body Package_Body is
1048

1049
      procedure Visit_Architecture_Instance (E : Node_Id);
1050
      procedure Visit_Component_Instance (E : Node_Id);
1051
      procedure Visit_System_Instance (E : Node_Id);
1052
      procedure Visit_Process_Instance (E : Node_Id);
1053
      procedure Visit_Thread_Instance (E : Node_Id);
1054
      procedure Visit_Device_Instance (E : Node_Id);
1055
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
1056

1057
      function Task_Job_Body (E : Node_Id) return Node_Id;
1058
      --  Creates the parameterless subprogram body that does the
1059
      --  thread's job.
1060

1061
      function Make_Current_Mode_Declaration (E : Node_Id) return Node_Id;
1062
      --  Create, if necessary, the current mode variable declaration for
1063
      --  thread E.
1064

1065
      function Make_Mode_Updater_body (E : Node_Id) return Node_Id;
1066
      --  Create the procedure which will update the current mode
1067

1068
      Has_Hybrid_Threads       : Boolean            := False;
1069
      Hybrid_Thread_Elements   : List_Id            := No_List;
1070
      Last_Hybrid_Thread_Index : Unsigned_Long_Long := 0;
1071

1072 1
      Current_Mode_Identifier : Node_Id;
1073

1074
      --  The runtime routines are generated per thread component and
1075
      --  not per thread instance. For each thread instance, we must
1076
      --  complete the case alternative specific to it in each one of
1077
      --  the routines. To perform this, we attache to each thread
1078
      --  component a set of List_Id's which represent the case
1079
      --  statement of the corresponding routines. The entities below
1080
      --  allow to Get/Set these list for each thread component.
1081

1082 1
      Interrogation_Routine_List : List_Id;
1083
      --  This list will hold all the bodies declarations of the
1084
      --  interrogation routines. We do this to ensure all the bodies
1085
      --  are appended after all entities generated for threads since
1086
      --  they need visibility on these entities.
1087

1088
      -------------------
1089
      -- Task_Job_Body --
1090
      -------------------
1091

1092 1
      function Task_Job_Body (E : Node_Id) return Node_Id is
1093 1
         S    : constant Node_Id := Parent_Subcomponent (E);
1094
         Spec : constant Node_Id :=
1095 1
           ADN.Job_Node (Backend_Node (Identifier (S)));
1096 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
1097 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
1098
         P            : constant Supported_Thread_Dispatch_Protocol :=
1099 1
           Get_Thread_Dispatch_Protocol (E);
1100
         Impl_Kind : constant Supported_Thread_Implementation :=
1101 1
           Get_Thread_Implementation_Kind (E);
1102 1
         Need_Error_Initialization : Boolean := True;
1103

1104
         function Make_Get_Valid_Value (F : Node_Id) return Node_Id;
1105
         --  This function generated an If statement that tests
1106
         --  whether the port ever received a value. In this case, it
1107
         --  returns tha last received value. Otherwithe, it return
1108
         --  the default value for the port data type.
1109

1110
         --------------------------------------------------------------
1111
         -- All routines below do NOT perfom any verification on the --
1112
         -- thread and rely completely on the good faith of their    --
1113
         -- caller.                                                  --
1114
         --------------------------------------------------------------
1115

1116
         procedure Make_Mode_Update;
1117
         --  Generate a case statement that updates the thread mode
1118
         --  depending on the received event port. The event port that
1119
         --  causes the mode switch is dequeued.
1120

1121
         procedure Make_Fetch_In_Ports;
1122
         --  Generate the routines to fetch the values of the thread
1123
         --  IN ports in a non-blocking way.
1124

1125
         procedure Make_Fetch_In_Ports
1126
           (Statements   : List_Id;
1127
            Declarations : List_Id);
1128
         --  Generate the routines to fetch the values of the thread
1129
         --  IN ports in a non-blocking way, puting the result in
1130
         --  the parameters.
1131

1132
         procedure Make_Dequeue_In_Ports;
1133
         --  Generate the routines to dequeue the oldest values of the
1134
         --  thread IN ports in a non-blocking way.
1135

1136
         procedure Make_Dequeue_In_Ports
1137
           (Statements   : List_Id;
1138
            Declarations : List_Id);
1139
         --  Generate the routines to dequeue the oldest values of the
1140
         --  thread IN ports in a non-blocking way, puting the results
1141
         --  in the parameters.
1142

1143
         procedure Make_Call_Sequence (CS : Node_Id := No_Node);
1144
         --  Generate code relying on the thread call sequence
1145

1146
         procedure Make_Thread_Compute_Entrypoint;
1147
         --  Generate code relying on the thread's own compute
1148
         --  entrypoint.
1149

1150
         procedure Make_Ports_Compute_Entrypoint;
1151
         --  Generate code relying on the compute entrypoints of the
1152
         --  thread ports.
1153

1154
         procedure Make_Set_Call_Sequence_Out_Ports
1155
           (CS         : Node_Id;
1156
            Statements : List_Id);
1157
         --  Generate the routines to set the values of the thread OUT
1158
         --  ports used by the call sequence CS.
1159

1160
         procedure Make_Send_Call_Sequence_Out_Ports
1161
           (CS         : Node_Id;
1162
            Statements : List_Id);
1163
         --  Generate the routines to send the values of the thread
1164
         --  OUT ports from teh call sequence CS.
1165

1166
         procedure Make_Set_Out_Ports;
1167
         --  Generate the routines to set the values of the thread
1168
         --  OUT ports.
1169

1170
         procedure Make_Send_Out_Ports;
1171
         --  Generate the routines to send the values of the thread
1172
         --  OUT ports.
1173

1174
         procedure Create_Call_Sequence
1175
           (Stats : List_Id;
1176
            Decl  : List_Id;
1177
            CS    : Node_Id := No_Node;
1178
            Port  : Node_Id := No_Node);
1179

1180
         --------------------------
1181
         -- Make_Get_Valid_Value --
1182
         --------------------------
1183

1184 1
         function Make_Get_Valid_Value (F : Node_Id) return Node_Id is
1185
            Then_Statements : constant List_Id :=
1186 1
              New_List (ADN.K_Statement_List);
1187
            Else_Statements : constant List_Id :=
1188 1
              New_List (ADN.K_Statement_List);
1189 1
            Condition : Node_Id;
1190 1
            N         : Node_Id;
1191
         begin
1192
            --  The condition of validity is that the return value of
1193
            --  Get_Count is different from -1.
1194

1195
            Condition :=
1196 1
              Make_Expression
1197 1
                (Map_Ada_Defining_Identifier (F, "C"),
1198
                 Op_Not_Equal,
1199 1
                 Make_Literal (New_Integer_Value (1, -1, 10)));
1200

1201
            --  Then
1202

1203 1
            N := Make_Subprogram_Call
1204 1
              (Get_Fully_Qualified_Subprogram (SN (S_Get_Value)),
1205 1
               Make_List_Id
1206 1
                 (Make_Defining_Identifier (VN (V_Id)),
1207 1
                  Map_Ada_Defining_Identifier (F),
1208 1
                  Map_Ada_Defining_Identifier (F, "I")));
1209

1210 1
            Append_Node_To_List (N, Then_Statements);
1211

1212 1
            N := Make_Selected_Component
1213 1
              (Map_Ada_Defining_Identifier (F, "I"),
1214 1
               Make_Defining_Identifier (Map_Ada_Component_Name (F)));
1215

1216
            N :=
1217 1
              Make_Assignment_Statement
1218 1
                (Map_Ada_Defining_Identifier (F, "V"),
1219
                 N);
1220 1
            Append_Node_To_List (N, Then_Statements);
1221

1222
            --  Else
1223

1224
            N :=
1225 1
              Extract_Designator
1226 1
                (ADN.Default_Value_Node
1227 1
                   (Backend_Node (Identifier (Corresponding_Instance (F)))));
1228

1229
            N :=
1230 1
              Make_Assignment_Statement
1231 1
                (Map_Ada_Defining_Identifier (F, "V"),
1232
                 N);
1233 1
            Append_Node_To_List (N, Else_Statements);
1234

1235
            N :=
1236 1
              Make_If_Statement
1237
                (Condition       => Condition,
1238
                 Then_Statements => Then_Statements,
1239
                 Else_Statements => Else_Statements);
1240 1
            return N;
1241
         end Make_Get_Valid_Value;
1242

1243
         ----------------------
1244
         -- Make_Mode_Update --
1245
         ----------------------
1246

1247 1
         procedure Make_Mode_Update is
1248 1
            Alternatives       : constant List_Id := New_List (ADN.K_List_Id);
1249 1
            Inner_Alternatives : List_Id;
1250 1
            Choices            : List_Id;
1251 1
            Inner_Statements   : List_Id;
1252 1
            F                  : Node_Id;
1253 1
            N                  : Node_Id;
1254 1
            M                  : Node_Id;
1255 1
            Src                : Node_Id;
1256

1257
            function Belongs (F : Node_Id; L : List_Id) return Boolean;
1258
            --  Return True IFF F is referenced by one of the entity
1259
            --  reference instances of list L.
1260

1261
            -------------
1262
            -- Belongs --
1263
            -------------
1264

1265 1
            function Belongs (F : Node_Id; L : List_Id) return Boolean is
1266 1
               Ref : Node_Id;
1267
            begin
1268 1
               Ref := First_Node (L);
1269

1270 1
               while Present (Ref) loop
1271 1
                  if F = Item (Last_Node (Path (Ref))) then
1272 1
                     return True;
1273
                  end if;
1274

1275 1
                  Ref := Next_Node (Ref);
1276 1
               end loop;
1277

1278 1
               return False;
1279
            end Belongs;
1280

1281
         begin
1282
            --  If no mode transition description is given, we do not
1283
            --  have to generate anything
1284

1285 1
            if AINU.Is_Empty (Mode_transitions (E)) then
1286 0
               return;
1287
            end if;
1288

1289
            --  FIXME: Taking account of port urgency should NOT be
1290
            --  implemented here but in the event delivery routine
1291
            --  (thread interrogators).
1292

1293
            --  If the thread is sporadic, we already got the value of
1294
            --  the port that triggered the thread. If the thread is
1295
            --  sporadic, we read the value of the oldest triggered
1296
            --  event port.
1297

1298 1
            if P = Thread_Periodic then
1299
               --  Declare the Port and Valid variables
1300

1301
               N :=
1302 0
                 Make_Object_Declaration
1303
                   (Defining_Identifier =>
1304 0
                      Make_Defining_Identifier (PN (P_Port)),
1305
                    Object_Definition =>
1306 0
                      Make_Defining_Identifier
1307 0
                        (Map_Port_Enumeration_Name (E)));
1308 0
               Append_Node_To_List (N, Declarations);
1309

1310
               N :=
1311 0
                 Make_Object_Declaration
1312
                   (Defining_Identifier =>
1313 0
                      Make_Defining_Identifier (PN (P_Valid)),
1314 0
                    Object_Definition => RE (RE_Boolean));
1315 0
               Append_Node_To_List (N, Declarations);
1316

1317
               --  Call Get_Next_Event
1318

1319 0
               N := Make_Defining_Identifier (SN (S_Get_Next_Event));
1320 0
               Set_Homogeneous_Parent_Unit_Name
1321
                 (N,
1322 0
                  Make_Defining_Identifier (Map_Interrogators_Name (E)));
1323

1324
               N :=
1325 0
                 Make_Subprogram_Call
1326
                   (N,
1327 0
                    Make_List_Id
1328 0
                      (Make_Defining_Identifier (PN (P_Port)),
1329 0
                       Make_Defining_Identifier (PN (P_Valid))));
1330 0
               Append_Node_To_List (N, Statements);
1331
            end if;
1332

1333
            --  We generate a global case statement basing on the
1334
            --  received (or read) port. Each alternative of the
1335
            --  statement contains a nested case statement based on
1336
            --  the current mode value to perform the switch.
1337

1338 1
            F := First_Node (Features (E));
1339

1340 1
            while Present (F) loop
1341 1
               if Kind (F) = K_Port_Spec_Instance
1342 1
                 and then not AIN.Is_Data (F)
1343
               then
1344 1
                  M                  := First_Node (Mode_transitions (E));
1345 1
                  Inner_Alternatives := New_List (ADN.K_Statement_List);
1346

1347 1
                  while Present (M) loop
1348
                     --  If F belongs to the port list of the mode
1349
                     --  transition M, generate necessary case
1350
                     --  alternative for the mode change. We are sure
1351
                     --  this works using case statements without
1352
                     --  having the risk of to case alternative with
1353
                     --  the same labels means the mode switch state
1354
                     --  machine is not deterministic as stated by the
1355
                     --  AADL standard.
1356

1357 1
                     if Belongs (F, Triggers (M)) then
1358
                        --  For each one of the source ports of M
1359
                        --  generate an inner case alternatice that
1360
                        --  effects the mode switch.
1361

1362 1
                        Src              := First_Node (Source_Modes (M));
1363 1
                        Choices          := New_List (ADN.K_List_Id);
1364 1
                        Inner_Statements := New_List (ADN.K_Statement_List);
1365

1366 1
                        while Present (Src) loop
1367 1
                           N := Map_Ada_Defining_Identifier (Item (Src));
1368 1
                           Append_Node_To_List (N, Choices);
1369

1370 1
                           Src := Next_Node (Src);
1371 1
                        end loop;
1372

1373
                        --  Perform the mode change
1374

1375
                        N :=
1376 1
                          Make_Assignment_Statement
1377 1
                            (Make_Defining_Identifier
1378 1
                               (Map_Current_Mode_Name (E)),
1379 1
                             Map_Ada_Defining_Identifier
1380 1
                               (Item (Destination_Mode (M))));
1381 1
                        Append_Node_To_List (N, Inner_Statements);
1382

1383
                        --  Dequeue the event port
1384

1385
                        --  Create a qualified value of the port enumerator
1386
                        --  to avoid name clashing between ports.
1387

1388
                        N :=
1389 1
                          Make_Record_Aggregate
1390 1
                            (Make_List_Id
1391 1
                               (Make_Defining_Identifier (PN (P_Port))));
1392

1393
                        N :=
1394 1
                          Make_Qualified_Expression
1395 1
                            (Make_Defining_Identifier
1396 1
                               (Map_Port_Enumeration_Name (E)),
1397
                             N);
1398

1399
                        --  Call Next_Value
1400

1401
                        N :=
1402 1
                          Make_Subprogram_Call
1403 1
                            (Get_Fully_Qualified_Subprogram
1404
                               (SN (S_Next_Value)),
1405 1
                             Make_List_Id
1406 1
                               (Make_Defining_Identifier (VN (V_Id)), N));
1407 1
                        Append_Node_To_List (N, Inner_Statements);
1408

1409
                        N :=
1410 1
                          Make_Case_Statement_Alternative
1411
                            (Choices,
1412
                             Inner_Statements);
1413 1
                        Append_Node_To_List (N, Inner_Alternatives);
1414
                     end if;
1415

1416 1
                     M := Next_Node (M);
1417 1
                  end loop;
1418

1419
                  --  If the port triggers at least one mode switch,
1420
                  --  add a case alternative
1421

1422 1
                  if not Is_Empty (Inner_Alternatives) then
1423
                     --  Default case alternative (when others => null;)
1424

1425 1
                     N := Make_Case_Statement_Alternative (No_List, No_List);
1426 1
                     Append_Node_To_List (N, Inner_Alternatives);
1427

1428
                     N :=
1429 1
                       Make_Case_Statement
1430 1
                         (Make_Defining_Identifier (Map_Current_Mode_Name (E)),
1431
                          Inner_Alternatives);
1432

1433
                     --  External case alternative
1434

1435
                     N :=
1436 1
                       Make_Case_Statement_Alternative
1437 1
                         (Make_List_Id (Map_Ada_Defining_Identifier (F)),
1438 1
                          Make_List_Id (N));
1439 1
                     Append_Node_To_List (N, Alternatives);
1440
                  end if;
1441
               end if;
1442

1443 1
               F := Next_Node (F);
1444 1
            end loop;
1445

1446
            --  Default case alternative (when others => null;)
1447

1448 1
            N := Make_Case_Statement_Alternative (No_List, No_List);
1449 1
            Append_Node_To_List (N, Alternatives);
1450

1451
            --  Make the case statement
1452

1453
            N :=
1454 1
              Make_Case_Statement
1455 1
                (Make_Defining_Identifier (PN (P_Port)),
1456
                 Alternatives);
1457

1458
            --  If the thread is sporadic, the case statement is added
1459
            --  directly to the thread job statements. If the thread
1460
            --  is periodic, the case statement is executed only if
1461
            --  'Valid' is True.
1462

1463 1
            if P = Thread_Periodic then
1464
               N :=
1465 0
                 Make_If_Statement
1466 0
                   (Condition       => Make_Defining_Identifier (PN (P_Valid)),
1467 0
                    Then_Statements => Make_List_Id (N));
1468
            end if;
1469

1470 1
            Append_Node_To_List (N, Statements);
1471
         end Make_Mode_Update;
1472

1473
         -------------------------
1474
         -- Make_Fetch_In_Ports --
1475
         -------------------------
1476

1477 1
         procedure Make_Fetch_In_Ports is
1478
         begin
1479 1
            Make_Fetch_In_Ports
1480
              (Statements   => Statements,
1481
               Declarations => Declarations);
1482 1
         end Make_Fetch_In_Ports;
1483

1484
         -------------------------
1485
         -- Make_Fetch_In_Ports --
1486
         -------------------------
1487

1488 1
         procedure Make_Fetch_In_Ports
1489
           (Statements   : List_Id;
1490
            Declarations : List_Id)
1491
         is
1492 1
            N : Node_Id;
1493 1
            F : Node_Id;
1494
         begin
1495 1
            N := Message_Comment ("Get the IN port values");
1496 1
            Append_Node_To_List (N, Statements);
1497 1
            F := First_Node (Features (E));
1498

1499 1
            while Present (F) loop
1500 1
               if Kind (F) = K_Port_Spec_Instance
1501 1
                 and then Is_In (F)
1502 1
                 and then AIN.Is_Data (F)
1503
               then
1504
                  --  Declare local variable
1505

1506
                  N :=
1507 1
                    Make_Object_Declaration
1508
                      (Defining_Identifier =>
1509 1
                         Map_Ada_Defining_Identifier (F, "V"),
1510
                       Object_Definition =>
1511 1
                         Map_Ada_Data_Type_Designator
1512 1
                           (Corresponding_Instance (F)));
1513 1
                  Append_Node_To_List (N, Declarations);
1514

1515
                  N :=
1516 1
                    Make_Object_Declaration
1517
                      (Defining_Identifier =>
1518 1
                         Map_Ada_Defining_Identifier (F, "I"),
1519
                       Object_Definition =>
1520 1
                       Make_Defining_Identifier (Map_Port_Interface_Name (E)));
1521 1
                  Append_Node_To_List (N, Declarations);
1522

1523
                  N :=
1524 1
                    Make_Object_Declaration
1525
                      (Defining_Identifier =>
1526 1
                         Map_Ada_Defining_Identifier (F, "C"),
1527
                       Constant_Present  => True,
1528 1
                       Object_Definition => RE (RE_Integer),
1529
                       Expression        =>
1530 1
                         Make_Subprogram_Call
1531 1
                           (Get_Fully_Qualified_Subprogram (SN (S_Get_Count)),
1532 1
                            Make_List_Id
1533 1
                              (Make_Defining_Identifier (VN (V_Id)),
1534 1
                               Make_Qualified_Expression
1535 1
                                 (Make_Defining_Identifier
1536 1
                                    (Map_Port_Enumeration_Name (E)),
1537 1
                                  Make_Record_Aggregate
1538 1
                                    (Make_List_Id
1539 1
                                       (Map_Ada_Defining_Identifier (F)))))));
1540

1541 1
                  Append_Node_To_List (N, Declarations);
1542

1543
                  --  Assign the port value
1544

1545 1
                  N := Make_Get_Valid_Value (F);
1546 1
                  Append_Node_To_List (N, Statements);
1547

1548
                  --  If the in port has not any destination inside
1549
                  --  the thread and in the call sequence (if specified),
1550
                  --  display a warning
1551

1552 1
                  if AINU.Is_Empty (Destinations (F)) then
1553 0
                     Display_Located_Error
1554 0
                       (AIN.Loc (F),
1555
                        "This IN port has no destination inside the thread." &
1556
                        " This could be an inconsistency in the AADL model",
1557
                        Fatal   => False,
1558
                        Warning => True);
1559
                  end if;
1560
               end if;
1561

1562 1
               F := Next_Node (F);
1563 1
            end loop;
1564 1
         end Make_Fetch_In_Ports;
1565

1566
         ---------------------------
1567
         -- Make_Dequeue_In_Ports --
1568
         ---------------------------
1569

1570 1
         procedure Make_Dequeue_In_Ports is
1571
         begin
1572 1
            Make_Dequeue_In_Ports
1573
              (Statements   => Statements,
1574
               Declarations => Declarations);
1575 1
         end Make_Dequeue_In_Ports;
1576

1577
         ---------------------------
1578
         -- Make_Dequeue_In_Ports --
1579
         ---------------------------
1580

1581 1
         procedure Make_Dequeue_In_Ports
1582
           (Statements   : List_Id;
1583
            Declarations : List_Id)
1584
         is
1585
            pragma Unreferenced (Declarations);
1586 1
            N                   : Node_Id;
1587 1
            F                   : Node_Id;
1588 1
            First_Port_Dequeued : Boolean := True;
1589
         begin
1590 1
            F := First_Node (Features (E));
1591

1592 1
            while Present (F) loop
1593 1
               if Kind (F) = K_Port_Spec_Instance
1594 1
                 and then Is_In (F)
1595 1
                 and then Is_Event (F)
1596
               then
1597 1
                  if First_Port_Dequeued then
1598 1
                     N := Message_Comment ("Dequeue the IN port values");
1599 1
                     Append_Node_To_List (N, Statements);
1600 1
                     First_Port_Dequeued := False;
1601
                  end if;
1602

1603
                  --  Create a qualified value of the port enumerator
1604
                  --  to avoid name clashing between ports.
1605

1606
                  N :=
1607 1
                    Make_Record_Aggregate
1608 1
                      (Make_List_Id (Map_Ada_Defining_Identifier (F)));
1609

1610
                  N :=
1611 1
                    Make_Qualified_Expression
1612 1
                      (Make_Defining_Identifier
1613 1
                         (Map_Port_Enumeration_Name (E)),
1614
                       N);
1615

1616
                  --  Call Next_Value
1617

1618
                  N :=
1619 1
                    Make_Subprogram_Call
1620 1
                      (Get_Fully_Qualified_Subprogram (SN (S_Next_Value)),
1621 1
                       Make_List_Id
1622 1
                         (Make_Defining_Identifier (VN (V_Id)),
1623
                          N));
1624

1625 1
                  Append_Node_To_List (N, Statements);
1626
               end if;
1627

1628 1
               F := Next_Node (F);
1629 1
            end loop;
1630 1
         end Make_Dequeue_In_Ports;
1631

1632
         ------------------------
1633
         -- Make_Call_Sequence --
1634
         ------------------------
1635

1636 1
         procedure Make_Call_Sequence (CS : Node_Id := No_Node) is
1637
         begin
1638 1
            Create_Call_Sequence
1639
              (Stats => Statements,
1640
               Decl  => Declarations,
1641
               CS    => CS,
1642
               Port  => No_Node);
1643 1
         end Make_Call_Sequence;
1644

1645
         --------------------------
1646
         -- Create_Call_Sequence --
1647
         --------------------------
1648

1649 1
         procedure Create_Call_Sequence
1650
           (Stats : List_Id;
1651
            Decl  : List_Id;
1652
            CS    : Node_Id := No_Node;
1653
            Port  : Node_Id := No_Node)
1654
         is
1655
            pragma Assert
1656 1
              (No (CS) or else Kind (CS) = K_Call_Sequence_Instance);
1657

1658
            function In_Modes_To_Choices (L : List_Id) return List_Id;
1659
            --  Converts an In_Modes (modes only) list into a case
1660
            --  statement alternative choice list.
1661

1662
            -------------------------
1663
            -- In_Modes_To_Choices --
1664
            -------------------------
1665

1666 1
            function In_Modes_To_Choices (L : List_Id) return List_Id is
1667 1
               Choices : constant List_Id := New_List (ADN.K_List_Id);
1668 1
               M       : Node_Id;
1669
            begin
1670 1
               M := First_Node (L);
1671

1672 1
               while Present (M) loop
1673 1
                  Append_Node_To_List
1674 1
                    (Map_Ada_Defining_Identifier (Item (M)),
1675
                     Choices);
1676

1677 1
                  M := Next_Node (M);
1678 1
               end loop;
1679

1680 1
               return Choices;
1681
            end In_Modes_To_Choices;
1682

1683 1
            Call_Seq : Node_Id;
1684 1
            N        : Node_Id;
1685
         begin
1686 1
            if No (CS) or else Has_Modes (E) then
1687 1
               Call_Seq := First_Node (Calls (E));
1688
            else
1689 0
               Call_Seq := CS;
1690
            end if;
1691

1692 1
            if not Has_Modes (E) or else AINU.Length (Calls (E)) = 1 then
1693
               --  If the thread has no modes, then it should have one
1694
               --  unique call sequence, handle it.
1695

1696 1
               Handle_Call_Sequence
1697
                 (E,
1698 1
                  Extract_Enumerator (E),
1699
                  Call_Seq,
1700
                  Decl,
1701
                  Stats);
1702

1703 1
               Make_Set_Call_Sequence_Out_Ports (Call_Seq, Stats);
1704 1
               Make_Send_Call_Sequence_Out_Ports (Call_Seq, Stats);
1705

1706
               --  If the thread is sporadic and there is no
1707
               --  ambiguity in the call sequence to be called,
1708
               --  then the 'Port' parameter is not used
1709

1710 1
               if not AINU.Is_Empty (AIN.Calls (E))
1711 1
                 and then AINU.Length (AIN.Calls (E)) <= 1
1712 1
                 and then
1713 1
                 ((Get_Thread_Dispatch_Protocol (E) = Thread_Sporadic)
1714
                  or else
1715 1
                  (Get_Thread_Dispatch_Protocol (E) = Thread_Aperiodic))
1716
               then
1717
                  N :=
1718 1
                    Make_Pragma_Statement
1719
                      (Pragma_Unreferenced,
1720 1
                       Make_List_Id (Make_Defining_Identifier (PN (P_Port))));
1721 1
                  Append_Node_To_List (N, Decl);
1722
               end if;
1723
            else
1724
               declare
1725 1
                  Alternatives  : constant List_Id := New_List (ADN.K_List_Id);
1726 1
                  Alt_Sts       : List_Id;
1727 1
                  Share_In_Port : Boolean;
1728 1
                  CS_Cnt        : Natural          := 0;
1729
               begin
1730 1
                  while Present (Call_Seq) loop
1731 1
                     Share_In_Port := No (Port);
1732 1
                     if Present (CS) and then Present (Port) then
1733
                        --  If there is a specified call sequence,
1734
                        --  we want to create call sequences from the
1735
                        --  same ports
1736

1737
                        declare
1738 0
                           Mode : Name_Id;
1739 0
                           G    : Node_Id;
1740 0
                           CE   : Node_Id;
1741
                        begin
1742 0
                           G := AIN.First_Node (AIN.Modes (E));
1743 0
                           while Present (G) loop
1744 0
                              Mode := AIN.Name (AIN.Identifier (G));
1745 0
                              CE   := Get_Port_Compute_Entrypoint (Port, Mode);
1746 0
                              if Present (CE) then
1747
                                 declare
1748
                                    Value : constant Node_Id :=
1749 0
                                      ATN.Expanded_Single_Value
1750 0
                                        (AIN.Property_Association_Value (CE));
1751
                                 begin
1752 0
                                    if ATN.Entity
1753 0
                                        (ATN.Reference_Term (Value)) =
1754
                                      Call_Seq
1755
                                    then
1756 0
                                       Share_In_Port := True;
1757 0
                                       exit;
1758
                                    end if;
1759
                                 end;
1760
                              end if;
1761

1762 0
                              G := AIN.Next_Node (G);
1763 0
                           end loop;
1764
                        end;
1765
                     end if;
1766

1767 1
                     if Share_In_Port then
1768
                        --  Handle the call sequence inside the case
1769
                        --  alternative statements.
1770

1771 1
                        Alt_Sts := New_List (ADN.K_Statement_List);
1772 1
                        Handle_Call_Sequence
1773
                          (E,
1774 1
                           Extract_Enumerator (E),
1775
                           Call_Seq,
1776
                           Decl,
1777
                           Alt_Sts);
1778

1779 1
                        Make_Set_Call_Sequence_Out_Ports (Call_Seq, Alt_Sts);
1780 1
                        Make_Send_Call_Sequence_Out_Ports (Call_Seq, Alt_Sts);
1781

1782 1
                        if Present (AIN.In_Modes (Call_Seq))
1783 1
                          and then not AINU.Is_Empty
1784 1
                            (AIN.Modes (AIN.In_Modes (Call_Seq)))
1785
                        then
1786
                           --  Generate a case statement alternative that
1787
                           --  handles this sequence.
1788

1789
                           N :=
1790 1
                             Make_Case_Statement_Alternative
1791 1
                               (In_Modes_To_Choices
1792 1
                                  (AIN.Modes (In_Modes (Call_Seq))),
1793
                                Alt_Sts);
1794 1
                           Append_Node_To_List (N, Alternatives);
1795 1
                           CS_Cnt := CS_Cnt + 1;
1796
                        end if;
1797

1798
                     end if;
1799 1
                     Call_Seq := Next_Node (Call_Seq);
1800 1
                  end loop;
1801

1802 1
                  if CS_Cnt = 0 then
1803
                     --  We are sure this is the unique call
1804
                     --  sequence without in_modes statement. As
1805
                     --  stated by the standard it should be used
1806
                     --  when none of the other call sequences
1807
                     --  match.
1808

1809 0
                     N := Make_Case_Statement_Alternative (No_List, Alt_Sts);
1810 0
                     Append_Node_To_List (N, Alternatives);
1811
                  else
1812
                     --  Default case alternative (when others => null;)
1813

1814 1
                     N := Make_Case_Statement_Alternative (No_List, No_List);
1815 1
                     Append_Node_To_List (N, Alternatives);
1816
                  end if;
1817

1818
                  N :=
1819 1
                    Make_Case_Statement
1820 1
                      (Make_Defining_Identifier (Map_Current_Mode_Name (E)),
1821
                       Alternatives);
1822

1823 1
                  if Is_Fusioned (E) and then CS_Cnt > 1 then
1824 0
                     declare
1825 0
                        N2 : Node_Id;
1826
                     begin
1827
                        N2 :=
1828 0
                          Make_Used_Package
1829 0
                            (Make_Designator
1830 0
                               (Map_Scheduler_Instance_Object_Name (E),
1831 0
                                Map_Scheduler_Instance_Name (E)));
1832 0
                        Append_Node_To_List (N2, Declarations);
1833

1834
                        N2 :=
1835 0
                          Make_Assignment_Statement
1836 0
                            (Make_Defining_Identifier (SN (S_R_Continue)),
1837 0
                             Make_Defining_Identifier (SN (S_True)));
1838 0
                        Append_Node_To_List (N2, Stats);
1839

1840
                        N2 :=
1841 0
                          Make_Exit_When_Statement
1842 0
                            (Make_Expression
1843 0
                               (Make_Defining_Identifier (SN (S_R_Continue)),
1844
                                Op_Not));
1845 0
                        N := Make_Loop_Statement (Make_List_Id (N, N2));
1846 0
                        Append_Node_To_List (N, Stats);
1847
                     end;
1848
                  else
1849 1
                     Append_Node_To_List (N, Stats);
1850
                  end if;
1851
               end;
1852
            end if;
1853 1
         end Create_Call_Sequence;
1854

1855
         ------------------------------------
1856
         -- Make_Thread_Compute_Entrypoint --
1857
         ------------------------------------
1858

1859 1
         procedure Make_Thread_Compute_Entrypoint is
1860 1
            N            : Node_Id;
1861 1
            Call_Profile : List_Id;
1862
         begin
1863 1
            N := Message_Comment ("Call the thread compute entrypoint");
1864 1
            Append_Node_To_List (N, Statements);
1865

1866
            --  If the entrypoint is set by Activate_Entrypoint_Source_Text,
1867
            --  then the parameters are implicit. If it is declared with
1868
            --  Activate_Entrypoint_Call_Sequence, the parameters are the
1869
            --  same as the call sequence single subprogram's.
1870

1871
            --  If the thread is periodic, then the compute
1872
            --  entrypoint's unique parameter is the enumerator
1873
            --  corresponding to the thread because the thread is
1874
            --  triggered with a time event. If the thread is sporadic
1875
            --  or hybrid then the compute entrypoint takes another
1876
            --  parameter which is the port that triggered the thread.
1877

1878 1
            case P is
1879 1
               when Thread_Periodic | Thread_Background =>
1880 1
                  Call_Profile := Make_List_Id (Extract_Enumerator (E));
1881

1882 1
               when Thread_Sporadic | Thread_Hybrid =>
1883
                  Call_Profile :=
1884 1
                    Make_List_Id
1885 1
                      (Extract_Enumerator (E),
1886 1
                       Make_Defining_Identifier (PN (P_Port)));
1887

1888 0
               when others =>
1889 0
                  raise Program_Error;
1890 1
            end case;
1891

1892
            --  If the thread has no modes, we just call the compute
1893
            --  entrypoint.
1894

1895 1
            if not Has_Modes (E) then
1896
               N :=
1897 1
                 Make_Subprogram_Call
1898 1
                   (Map_Ada_Subprogram_Identifier (E),
1899
                    Call_Profile);
1900 1
               Append_Node_To_List (N, Statements);
1901
            else
1902
               declare
1903 1
                  Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1904 1
                  Alt_Sts      : List_Id;
1905 1
                  CEP_Name     : Name_Id;
1906 1
                  Default      : Boolean          := False;
1907 1
                  M            : Node_Id := AIN.First_Node (AIN.Modes (E));
1908 1
                  Mode_Name    : Name_Id;
1909

1910
               begin
1911 1
                  while Present (M) loop
1912 1
                     Alt_Sts := New_List (ADN.K_Statement_List);
1913

1914 1
                     Mode_Name := AIN.Name (AIN.Identifier (M));
1915
                     CEP_Name  :=
1916 1
                       Get_Thread_Compute_Entrypoint
1917
                         (T       => E,
1918
                          In_Mode => Mode_Name);
1919

1920 1
                     if CEP_Name = No_Name then
1921
                        --  If there is no compute entry point
1922
                        --  associated to M, then this mode will be
1923
                        --  handled in the 'default' switch case.
1924

1925 0
                        Default := True;
1926
                     else
1927
                        N :=
1928 1
                          Make_Subprogram_Call
1929 1
                            (Map_Ada_Subprogram_Identifier (CEP_Name),
1930
                             Call_Profile);
1931

1932 1
                        Append_Node_To_List (N, Alt_Sts);
1933

1934
                        N :=
1935 1
                          Make_Case_Statement_Alternative
1936 1
                            (Make_List_Id (Map_Ada_Defining_Identifier (M)),
1937
                             Alt_Sts);
1938 1
                        Append_Node_To_List (N, Alternatives);
1939
                     end if;
1940

1941 1
                     M := AIN.Next_Node (M);
1942 1
                  end loop;
1943

1944 1
                  if Default then
1945
                     --  Default case alternative (when others =>
1946
                     --  <call default entrypoint> or <null>;)
1947

1948
                     CEP_Name :=
1949 0
                       Get_Thread_Compute_Entrypoint
1950
                         (T       => E,
1951
                          In_Mode => No_Name);
1952

1953 0
                     if CEP_Name = No_Name then
1954
                        N :=
1955 0
                          Make_Case_Statement_Alternative (No_List, No_List);
1956
                     else
1957
                        N :=
1958 0
                          Make_Case_Statement_Alternative
1959
                            (No_List,
1960 0
                             Make_List_Id
1961 0
                               (Map_Ada_Subprogram_Identifier (CEP_Name)));
1962
                     end if;
1963 0
                     Append_Node_To_List (N, Alternatives);
1964
                  end if;
1965

1966
                  N :=
1967 1
                    Make_Case_Statement
1968 1
                      (Make_Defining_Identifier (Map_Current_Mode_Name (E)),
1969
                       Alternatives);
1970 1
                  Append_Node_To_List (N, Statements);
1971
               end;
1972
            end if;
1973 1
         end Make_Thread_Compute_Entrypoint;
1974

1975
         -----------------------------------
1976
         -- Make_Ports_Compute_Entrypoint --
1977
         -----------------------------------
1978

1979 1
         procedure Make_Ports_Compute_Entrypoint is
1980 1
            N            : Node_Id;
1981 1
            F            : Node_Id;
1982 1
            Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1983 1
            Is_Reference : Boolean          := False;
1984 1
            Is_String    : Boolean          := False;
1985 1
            Caller_Nb    : Natural          := 0;
1986 1
            St           : List_Id          := No_List;
1987
         begin
1988
            N :=
1989 1
              Message_Comment
1990
                ("Depending on the triggered port, call" &
1991
                 " the corresponding compute " &
1992
                 "entrypoint.");
1993 1
            Append_Node_To_List (N, Statements);
1994

1995 1
            F := First_Node (Features (E));
1996 1
            while Present (F) loop
1997 1
               if Kind (F) = K_Port_Spec_Instance
1998 1
                 and then Is_In (F)
1999 1
                 and then Is_Event (F)
2000
               then
2001
                  declare
2002
                     use ATN;
2003

2004
                     Value : constant Node_Id :=
2005 1
                       ATN.Expanded_Single_Value
2006 1
                         (AIN.Property_Association_Value
2007 1
                            (Get_Thread_Compute_Entrypoint (F)));
2008
                  begin
2009 1
                     Caller_Nb := Caller_Nb + 1;
2010 1
                     St        := New_List (ADN.K_Statement_List);
2011

2012 1
                     if ATN.Kind (Value) = ATN.K_Reference_Term then
2013 0
                        if Is_String then
2014 0
                           Display_Located_Error
2015 0
                             (AIN.Loc (E),
2016
                              "Cannot use both compute_entrypoint and " &
2017
                              "compute_entrypoint_call_sequence in the " &
2018
                              "same thread.",
2019
                              Fatal => True);
2020
                        end if;
2021

2022 0
                        if not Is_Reference then
2023 0
                           Make_Fetch_In_Ports (Statements, Declarations);
2024 0
                           Make_Dequeue_In_Ports (Statements, Declarations);
2025 0
                           Is_Reference := True;
2026
                        end if;
2027

2028
                        declare
2029
                           Call_Seq : constant Node_Id :=
2030 0
                             ATN.Entity (ATN.Reference_Term (Value));
2031
                        begin
2032
                           --  Handle the thread call sequences
2033

2034 0
                           Create_Call_Sequence
2035
                             (St,
2036
                              Declarations,
2037
                              Call_Seq,
2038
                              F);
2039
                        end;
2040
                     else
2041 1
                        if Is_Reference then
2042 0
                           Display_Located_Error
2043 0
                             (AIN.Loc (E),
2044
                              "Cannot use both compute_entrypoint and " &
2045
                              "compute_entrypoint_call_sequence in the " &
2046
                              "same thread.",
2047
                              Fatal => True);
2048
                        end if;
2049 1
                        Is_String := True;
2050

2051 1
                        if AIN.Loc (F) = No_Location then
2052
                           N :=
2053 1
                             Message_Comment
2054
                               ("Received a period event from the hybrid" &
2055
                                " tasks driver");
2056 1
                           Append_Node_To_List (N, St);
2057
                        end if;
2058

2059
                        --  We only fetch and dequeue the usefull port
2060
                        --  (string entrypoint cannot access ports
2061
                        --  values others than their trigger)
2062

2063
                        --  Declare and read the variable current value
2064

2065 1
                        if AIN.Is_Data (F) then
2066
                           N :=
2067 1
                             Make_Object_Declaration
2068
                               (Defining_Identifier =>
2069 1
                                  Map_Ada_Defining_Identifier (F, "V"),
2070
                                Object_Definition =>
2071 1
                                  Map_Ada_Data_Type_Designator
2072 1
                                    (Corresponding_Instance (F)));
2073 1
                           Append_Node_To_List (N, Declarations);
2074
                           N :=
2075 1
                             Make_Object_Declaration
2076
                               (Defining_Identifier =>
2077 1
                                  Map_Ada_Defining_Identifier (F, "C"),
2078
                                Constant_Present  => True,
2079 1
                                Object_Definition => RE (RE_Integer),
2080
                                Expression        =>
2081 1
                                  Make_Subprogram_Call
2082 1
                                    (Get_Fully_Qualified_Subprogram
2083
                                       (SN (S_Get_Count)),
2084 1
                                     Make_List_Id
2085 1
                                       (Make_Defining_Identifier (VN (V_Id)),
2086 1
                                        Make_Qualified_Expression
2087 1
                                          (Make_Defining_Identifier
2088 1
                                             (Map_Port_Enumeration_Name (E)),
2089 1
                                           Make_Record_Aggregate
2090 1
                                             (Make_List_Id
2091 1
                                                (Map_Ada_Defining_Identifier
2092
                                                   (F)))))));
2093

2094 1
                           Append_Node_To_List (N, Declarations);
2095

2096
                           N :=
2097 1
                             Make_Object_Declaration
2098
                               (Defining_Identifier =>
2099 1
                                  Map_Ada_Defining_Identifier (F, "I"),
2100
                                Object_Definition =>
2101 1
                                  Make_Defining_Identifier
2102 1
                                    (Map_Port_Interface_Name (E)));
2103 1
                           Append_Node_To_List (N, Declarations);
2104

2105
                           --  Assign the port value
2106

2107 1
                           N := Make_Get_Valid_Value (F);
2108 1
                           Append_Node_To_List (N, St);
2109
                        end if;
2110

2111
                        --  Create a qualified value of the port
2112
                        --  enumerator to avoid name clashing
2113
                        --  between ports.
2114

2115 1
                        N := Message_Comment ("Dequeue the IN port values");
2116 1
                        Append_Node_To_List (N, St);
2117

2118
                        N :=
2119 1
                          Make_Record_Aggregate
2120 1
                            (Make_List_Id (Map_Ada_Defining_Identifier (F)));
2121
                        N :=
2122 1
                          Make_Qualified_Expression
2123 1
                            (Make_Defining_Identifier
2124 1
                               (Map_Port_Enumeration_Name (E)),
2125
                             N);
2126

2127
                        --  Call Next_Value
2128

2129
                        N :=
2130 1
                          Make_Subprogram_Call
2131 1
                            (Get_Fully_Qualified_Subprogram
2132
                               (SN (S_Next_Value)),
2133 1
                             Make_List_Id
2134 1
                               (Make_Defining_Identifier (VN (V_Id)), N));
2135 1
                        Append_Node_To_List (N, St);
2136

2137
                        --  Call the port compute entrypoint with the
2138
                        --  received value (if any).
2139

2140
                        declare
2141
                           Profile : constant List_Id :=
2142 1
                             Make_List_Id (Extract_Enumerator (E));
2143
                        begin
2144 1
                           if AIN.Is_Data (F) then
2145 1
                              Append_Node_To_List
2146 1
                                (Map_Ada_Defining_Identifier (F, "V"),
2147
                                 Profile);
2148
                           end if;
2149

2150
                           N :=
2151 1
                             Make_Subprogram_Call
2152 1
                               (Map_Ada_Subprogram_Identifier (F),
2153
                                Profile);
2154 1
                           Append_Node_To_List (N, St);
2155
                        end;
2156
                     end if;
2157

2158
                     --  Make the case statement alternative
2159

2160
                     N :=
2161 1
                       Make_Case_Statement_Alternative
2162 1
                         (Make_List_Id (Map_Ada_Defining_Identifier (F)),
2163
                          St);
2164 1
                     Append_Node_To_List (N, Alternatives);
2165 1
                  end;
2166
               end if;
2167

2168 1
               F := Next_Node (F);
2169 1
            end loop;
2170

2171 1
            if Caller_Nb > 1 then
2172
               N :=
2173 1
                 Make_Case_Statement_Alternative
2174
                   (No_List,
2175 1
                    Make_List_Id
2176 1
                      (Make_Raise_Statement
2177 1
                         (Make_Designator (EN (E_Program_Error)))));
2178 1
               Append_Node_To_List (N, Alternatives);
2179

2180
               --  Make the case statement
2181

2182
               N :=
2183 1
                 Make_Case_Statement
2184 1
                   (Make_Defining_Identifier (PN (P_Port)),
2185
                    Alternatives);
2186 1
               Append_Node_To_List (N, Statements);
2187

2188 1
            elsif Caller_Nb = 1 then
2189 1
               ADN.Set_Next_Node
2190 1
                 (ADN.Last_Node (Statements),
2191 1
                  ADN.First_Node (St));
2192 1
               ADN.Set_Last_Node (Statements, ADN.Last_Node (St));
2193

2194 1
               if Is_String
2195 1
                 and then Get_Thread_Dispatch_Protocol (E) = Thread_Sporadic
2196
               then
2197

2198
                  --  If the thread is sporadic, then the 'Port'
2199
                  --  parameter is not used
2200

2201
                  N :=
2202 1
                    Make_Pragma_Statement
2203
                      (Pragma_Unreferenced,
2204 1
                       Make_List_Id (Make_Defining_Identifier (PN (P_Port))));
2205 1
                  Append_Node_To_List (N, Declarations);
2206
               end if;
2207
            end if;
2208 1
         end Make_Ports_Compute_Entrypoint;
2209

2210
         --------------------------------------
2211
         -- Make_Set_Call_Sequence_Out_Ports --
2212
         --------------------------------------
2213

2214 1
         procedure Make_Set_Call_Sequence_Out_Ports
2215
           (CS         : Node_Id;
2216
            Statements : List_Id)
2217
         is
2218
            Wrapper : constant Node_Id :=
2219 1
              Corresponding_Instance (First_Node (Subprogram_Calls (CS)));
2220 1
            N        : Node_Id;
2221 1
            F        : Node_Id;
2222 1
            Find_One : Boolean := False;
2223
         begin
2224 1
            if AINU.Is_Empty (Features (E)) then
2225 1
               F := No_Node;
2226
            else
2227 1
               F := First_Node (Features (E));
2228
            end if;
2229 1
            while Present (F) loop
2230 1
               if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
2231
                  --  We do not set the ports that are connected to
2232
                  --  the call sequence wrapper out ports, this should be
2233
                  --  done during the subprogram call sequence handling.
2234
                  --  We also do not set OUT port that have not any sources.
2235

2236
                  declare
2237 1
                     D    : Node_Id := First_Node (Sources (F));
2238 1
                     Set  : Boolean := True;
2239 1
                     Used : Boolean := False;
2240
                  begin
2241
                     --  If the OUT port has not any sources, we
2242
                     --  display a warning.
2243

2244 1
                     if No (D) then
2245 1
                        Set := False;
2246

2247 1
                        Display_Located_Error
2248 1
                          (AIN.Loc (F),
2249
                           "This OUT port has no source from inside the" &
2250
                           " thread. This could be an inconsistency in the" &
2251
                           " AADL model",
2252
                           Fatal   => False,
2253
                           Warning => True);
2254
                     end if;
2255

2256 1
                     while Present (D) loop
2257 1
                        Set := Kind (Item (D)) /= K_Port_Spec_Instance;
2258 1
                        exit when not Set;
2259

2260 1
                        if not Used then
2261 1
                           if Parent_Component (Item (D)) = Wrapper then
2262 1
                              Used := True;
2263
                           end if;
2264
                        end if;
2265

2266 1
                        D := Next_Node (D);
2267 1
                     end loop;
2268

2269 1
                     if Used then
2270 1
                        if not Find_One then
2271 1
                           Find_One := True;
2272
                           N        :=
2273 1
                             Message_Comment
2274
                               ("Set the call sequence OUT port values");
2275 1
                           Append_Node_To_List (N, Statements);
2276
                        end if;
2277

2278
                        N :=
2279 1
                          Make_Record_Aggregate
2280 1
                            (Make_List_Id
2281 1
                               (Make_Component_Association
2282 1
                                  (Make_Defining_Identifier (CN (C_Port)),
2283 1
                                   Map_Ada_Defining_Identifier (F)),
2284 1
                                Make_Component_Association
2285 1
                                  (Make_Defining_Identifier
2286 1
                                     (Map_Ada_Component_Name (F)),
2287 1
                                   Map_Ada_Defining_Identifier (F, "V"))));
2288

2289
                        N :=
2290 1
                          Make_Qualified_Expression
2291 1
                            (Make_Defining_Identifier
2292 1
                               (Map_Port_Interface_Name (E)),
2293
                             N);
2294

2295
                        N :=
2296 1
                          Make_Subprogram_Call
2297 1
                            (Get_Fully_Qualified_Subprogram (SN (S_Put_Value)),
2298 1
                             Make_List_Id
2299 1
                               (Make_Defining_Identifier (VN (V_Id)), N));
2300

2301 1
                        Append_Node_To_List (N, Statements);
2302
                     end if;
2303
                  end;
2304
               end if;
2305

2306 1
               F := Next_Node (F);
2307 1
            end loop;
2308 1
         end Make_Set_Call_Sequence_Out_Ports;
2309

2310
         ---------------------------------------
2311
         -- Make_Send_Call_Sequence_Out_Ports --
2312
         ---------------------------------------
2313

2314 1
         procedure Make_Send_Call_Sequence_Out_Ports
2315
           (CS         : Node_Id;
2316
            Statements : List_Id)
2317
         is
2318
            Wrapper : constant Node_Id :=
2319 1
              Corresponding_Instance (First_Node (Subprogram_Calls (CS)));
2320 1
            N        : Node_Id;
2321 1
            F        : Node_Id;
2322 1
            Find_One : Boolean := False;
2323
         begin
2324 1
            if AINU.Is_Empty (Features (E)) then
2325 1
               F := No_Node;
2326
            else
2327 1
               F := First_Node (Features (E));
2328
            end if;
2329 1
            while Present (F) loop
2330 1
               if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
2331
                  declare
2332 1
                     D    : Node_Id := First_Node (Sources (F));
2333 1
                     Used : Boolean := False;
2334
                  begin
2335 1
                     while Present (D) loop
2336 1
                        if not Used then
2337 1
                           if Parent_Component (Item (D)) = Wrapper then
2338 1
                              Used := True;
2339
                           end if;
2340
                        end if;
2341

2342 1
                        exit when Kind (Item (D)) = K_Port_Spec_Instance;
2343

2344 1
                        D := Next_Node (D);
2345 1
                     end loop;
2346

2347 1
                     if Used then
2348 1
                        if not Find_One then
2349 1
                           Find_One := True;
2350
                           N        :=
2351 1
                             Message_Comment
2352
                               ("Send the call sequence OUT port values");
2353 1
                           Append_Node_To_List (N, Statements);
2354
                        end if;
2355
                        N :=
2356 1
                          Make_Subprogram_Call
2357 1
                            (Get_Fully_Qualified_Subprogram
2358
                               (SN (S_Send_Output)),
2359 1
                             Make_List_Id
2360 1
                               (Make_Defining_Identifier (VN (V_Id)),
2361 1
                                Make_Qualified_Expression
2362 1
                                  (Make_Defining_Identifier
2363 1
                                     (Map_Port_Enumeration_Name (E)),
2364 1
                                   Make_Record_Aggregate
2365 1
                                     (Make_List_Id
2366 1
                                        (Map_Ada_Defining_Identifier
2367
                                           (F)))),
2368 1
                                Make_Defining_Identifier (VN (V_Error))));
2369 1
                        Append_Node_To_List (N, Statements);
2370 1
                        Need_Error_Initialization := False;
2371
                     end if;
2372
                  end;
2373
               end if;
2374 1
               F := Next_Node (F);
2375 1
            end loop;
2376 1
         end Make_Send_Call_Sequence_Out_Ports;
2377

2378
         ------------------------
2379
         -- Make_Set_Out_Ports --
2380
         ------------------------
2381

2382 1
         procedure Make_Set_Out_Ports is
2383 1
            N : Node_Id;
2384 1
            F : Node_Id;
2385
         begin
2386 1
            N := Message_Comment ("Set the OUT port values");
2387 1
            Append_Node_To_List (N, Statements);
2388

2389 1
            F := First_Node (Features (E));
2390

2391 1
            while Present (F) loop
2392 1
               if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
2393
                  --  We do not set the ports that are connected to
2394
                  --  subprogram out ports, this should be done during
2395
                  --  the subprogram call sequence handling. We also
2396
                  --  do not set OUT port that have not any sources.
2397

2398
                  declare
2399 1
                     D   : Node_Id := First_Node (Sources (F));
2400 1
                     Set : Boolean := True;
2401
                  begin
2402
                     --  If the OUT port has not any sources, we
2403
                     --  display a warning.
2404

2405 1
                     if No (D) then
2406 1
                        Set := False;
2407

2408 1
                        Display_Located_Error
2409 1
                          (AIN.Loc (F),
2410
                           "This OUT port has no source from inside the" &
2411
                           " thread. This could be an inconsistency in the" &
2412
                           " AADL model",
2413
                           Fatal   => False,
2414
                           Warning => True);
2415
                     end if;
2416

2417 1
                     while Present (D) loop
2418 0
                        Set := Kind (Item (D)) /= K_Port_Spec_Instance;
2419 0
                        exit when not Set;
2420

2421 0
                        D := Next_Node (D);
2422 0
                     end loop;
2423

2424 1
                     if Set then
2425
                        N :=
2426 0
                          Make_Record_Aggregate
2427 0
                            (Make_List_Id
2428 0
                               (Make_Component_Association
2429 0
                                  (Make_Defining_Identifier (CN (C_Port)),
2430 0
                                   Map_Ada_Defining_Identifier (F)),
2431 0
                                Make_Component_Association
2432 0
                                  (Make_Defining_Identifier
2433 0
                                     (Map_Ada_Component_Name (F)),
2434 0
                                   Map_Ada_Defining_Identifier (F, "V"))));
2435

2436
                        N :=
2437 0
                          Make_Qualified_Expression
2438 0
                            (Make_Defining_Identifier
2439 0
                               (Map_Port_Interface_Name (E)),
2440
                             N);
2441

2442
                        N :=
2443 0
                          Make_Subprogram_Call
2444 0
                            (Get_Fully_Qualified_Subprogram (SN (S_Put_Value)),
2445 0
                             Make_List_Id (N));
2446

2447 0
                        Append_Node_To_List (N, Statements);
2448
                     end if;
2449
                  end;
2450
               end if;
2451

2452 1
               F := Next_Node (F);
2453 1
            end loop;
2454 1
         end Make_Set_Out_Ports;
2455

2456
         -------------------------
2457
         -- Make_Send_Out_Ports --
2458
         -------------------------
2459

2460 1
         procedure Make_Send_Out_Ports is
2461 1
            N : Node_Id;
2462 1
            F : Node_Id;
2463
         begin
2464 1
            N := Message_Comment ("Send the OUT ports");
2465 1
            Append_Node_To_List (N, Statements);
2466

2467 1
            F := First_Node (Features (E));
2468

2469 1
            while Present (F) loop
2470 1
               if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
2471
                  N :=
2472 1
                    Make_Subprogram_Call
2473 1
                      (Get_Fully_Qualified_Subprogram (SN (S_Send_Output)),
2474 1
                       Make_List_Id (RE (RE_Get_Task_Id),
2475 1
                                     Make_Qualified_Expression
2476 1
                                       (Make_Defining_Identifier
2477 1
                                          (Map_Port_Enumeration_Name (E)),
2478 1
                                        Make_Record_Aggregate
2479 1
                                          (Make_List_Id
2480 1
                                             (Map_Ada_Defining_Identifier
2481
                                                (F)))),
2482 1
                                     Make_Defining_Identifier (VN (V_Error))));
2483

2484 1
                  Append_Node_To_List (N, Statements);
2485 1
                  Need_Error_Initialization := False;
2486
               end if;
2487

2488 1
               F := Next_Node (F);
2489 1
            end loop;
2490 1
         end Make_Send_Out_Ports;
2491

2492 1
         N : Node_Id;
2493
      begin
2494 1
         Check_Thread_Consistency (E);
2495

2496 1
         if Has_Ports (E) then
2497 1
            Add_With_Package
2498 1
              (E    => RU (Ru_PolyORB_HI_Generated_Activity),
2499
               Used => True);
2500

2501
            N :=
2502 1
              Make_Object_Declaration
2503
              (Defining_Identifier =>
2504 1
                 Make_Defining_Identifier (VN (V_Id)),
2505
               Constant_Present  => True,
2506 1
               Object_Definition => RE (RE_Entity_Type),
2507 1
               Expression        => RE (RE_Get_Task_Id));
2508 1
            Append_Node_To_List (N, Declarations);
2509
         end if;
2510

2511
         --  If the thread contains operational modes. we update the
2512
         --  value of the current mode depending on the received
2513
         --  events.
2514

2515 1
         if Has_Modes (E) then
2516 1
            Make_Mode_Update;
2517
         end if;
2518

2519
         --  Depending on the implementation kind, call the proper
2520
         --  implementation routines.
2521

2522 1
         case Impl_Kind is
2523 1
            when Thread_With_Call_Sequence =>
2524
               --  This kind of implementation is the simplest
2525
               --  one. The user has only to implementation the
2526
               --  behaviour of subprograms and does not have to worry
2527
               --  about sending and receiving ports.
2528

2529
               --  Get IN ports values and dequeue them
2530

2531 1
               if Has_In_Ports (E) then
2532 1
                  Make_Fetch_In_Ports;
2533 1
                  Make_Dequeue_In_Ports;
2534
               end if;
2535

2536
               --  Handle the thread call sequences
2537

2538 1
               if not AINU.Is_Empty (Calls (E)) then
2539 1
                  Make_Call_Sequence;
2540
               end if;
2541

2542 1
            when Thread_With_Compute_Entrypoint =>
2543
               declare
2544
                  use ATN;
2545
                  Property : constant Node_Id :=
2546 1
                    Get_Thread_Compute_Entrypoint (E);
2547 1
                  Value : Node_Id;
2548
               begin
2549 1
                  if AIN.Kind (Property) = K_Component_Instance then
2550
                     --  Call the compute entrypoint. The code of the
2551
                     --  compute entry point will include the setting
2552
                     --  of the thread OUT ports.
2553

2554 0
                     Make_Thread_Compute_Entrypoint;
2555

2556
                     --  Send OUT ports.
2557

2558
                     --  XXX: Depending on an AADL property, the
2559
                     --  code of the thread entrypoint may include the
2560
                     --  sending of OUT ports. Which AADL property?
2561

2562 0
                     if Has_Out_Ports (E) then
2563 0
                        Make_Set_Out_Ports;
2564 0
                        Make_Send_Out_Ports;
2565
                     end if;
2566

2567
                  else
2568
                     Value :=
2569 1
                       Expanded_Single_Value
2570 1
                         (AIN.Property_Association_Value (Property));
2571

2572 1
                     if ATN.Kind (Value) = ATN.K_Reference_Term then
2573
                        --  Get IN ports values and dequeue them
2574

2575 0
                        if Has_In_Ports (E) then
2576 0
                           Make_Fetch_In_Ports;
2577 0
                           Make_Dequeue_In_Ports;
2578
                        end if;
2579

2580
                        --  Handle the thread call sequences
2581

2582 0
                        Make_Call_Sequence
2583 0
                          (ATN.Entity (ATN.Reference_Term (Value)));
2584
                     else
2585
                        --  Call the compute entrypoint. The code of the
2586
                        --  compute entry point will include the setting
2587
                        --  of the thread OUT ports.
2588

2589 1
                        Make_Thread_Compute_Entrypoint;
2590

2591
                        --  Send OUT ports.
2592

2593
                        --  XXX: Depending on an AADL property, the
2594
                        --  code of the thread entrypoint may include the
2595
                        --  sending of OUT ports. Which AADL property?
2596

2597 1
                        if Has_Out_Ports (E) then
2598 1
                           Make_Set_Out_Ports;
2599 1
                           Make_Send_Out_Ports;
2600
                        end if;
2601
                     end if;
2602
                  end if;
2603
               end;
2604

2605 1
            when Thread_With_Port_Compute_Entrypoint =>
2606
               --  Call the compute entrypoints of the triggeing
2607
               --  port. The code of the compute entry point will
2608
               --  include the sentting of the thread OUT ports.
2609

2610 1
               Make_Ports_Compute_Entrypoint;
2611 1
               if Has_Out_Ports (E) then
2612 1
                  Make_Set_Out_Ports;
2613 1
                  Make_Send_Out_Ports;
2614
               end if;
2615

2616 0
            when others =>
2617 0
               raise Program_Error with "Unconsistency in Task_Job_Body";
2618 1
         end case;
2619

2620
         --  Define Error variable
2621

2622 1
         if Need_Error_Initialization then
2623
            N :=
2624 1
              Make_Object_Declaration
2625
                (Defining_Identifier =>
2626 1
                   Make_Defining_Identifier (VN (V_Error)),
2627
                 Constant_Present  => True,
2628 1
                 Object_Definition => RE (RE_Error_Kind),
2629 1
                 Expression        => RE (RE_Error_None));
2630 1
            Append_Node_To_List (N, Declarations);
2631

2632
         else
2633
            N :=
2634 1
              Make_Object_Declaration
2635
                (Defining_Identifier =>
2636 1
                   Make_Defining_Identifier (VN (V_Error)),
2637 1
                 Object_Definition => RE (RE_Error_Kind));
2638 1
            Append_Node_To_List (N, Declarations);
2639
         end if;
2640

2641
         --  Return default error code: at this point, everything
2642
         --  has been properly handled.
2643

2644 1
         N := Message_Comment ("Return error code");
2645 1
         Append_Node_To_List (N, Statements);
2646

2647
         N :=
2648 1
           Make_Assignment_Statement
2649
             (Variable_Identifier =>
2650 1
                Make_Defining_Identifier (PN (P_Result)),
2651 1
              Expression => Make_Defining_Identifier (VN (V_Error)));
2652 1
         Append_Node_To_List (N, Statements);
2653

2654 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
2655 1
         return N;
2656
      end Task_Job_Body;
2657

2658
      -----------------------------------
2659
      -- Make_Current_Mode_Declaration --
2660
      -----------------------------------
2661

2662 1
      function Make_Current_Mode_Declaration (E : Node_Id) return Node_Id is
2663 1
         M : Node_Id;
2664 1
         N : Node_Id;
2665
      begin
2666
         --  The value of the global variable is the enumeratioin
2667
         --  literal corresponding to the initial mode of the thread.
2668

2669 1
         M := First_Node (Modes (E));
2670 1
         N := No_Node;
2671

2672 1
         while Present (M) loop
2673 1
            if Is_Initial (M) then
2674 1
               N := Map_Ada_Defining_Identifier (M);
2675 1
               exit;
2676
            end if;
2677

2678 0
            M := Next_Node (M);
2679 0
         end loop;
2680

2681
         --  If no initial mode has been found, there is definitely an
2682
         --  error in the analyzer.
2683

2684 1
         if No (N) then
2685 0
            raise Program_Error with "No initial mode in mode list";
2686
         end if;
2687

2688
         --  Declare the variable
2689

2690 1
         Current_Mode_Identifier :=
2691 1
           Make_Defining_Identifier (Map_Current_Mode_Name (E));
2692

2693
         N :=
2694 1
           Make_Object_Declaration
2695
             (Defining_Identifier => Current_Mode_Identifier,
2696
              Object_Definition   =>
2697 1
                Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)),
2698
              Expression => N);
2699

2700 1
         return N;
2701
      end Make_Current_Mode_Declaration;
2702

2703
      -----------
2704
      -- Visit --
2705
      -----------
2706

2707 1
      procedure Visit (E : Node_Id) is
2708
      begin
2709 1
         case Kind (E) is
2710 1
            when K_Architecture_Instance =>
2711 1
               Visit_Architecture_Instance (E);
2712

2713 1
            when K_Component_Instance =>
2714 1
               Visit_Component_Instance (E);
2715

2716 0
            when others =>
2717 0
               null;
2718 1
         end case;
2719 1
      end Visit;
2720

2721
      ---------------------------------
2722
      -- Visit_Architecture_Instance --
2723
      ---------------------------------
2724

2725 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
2726
      begin
2727 1
         Visit (Root_System (E));
2728 1
      end Visit_Architecture_Instance;
2729

2730
      ------------------------------
2731
      -- Visit_Component_Instance --
2732
      ------------------------------
2733

2734 1
      procedure Visit_Component_Instance (E : Node_Id) is
2735
         Category : constant Component_Category :=
2736 1
           Get_Category_Of_Component (E);
2737
      begin
2738 1
         case Category is
2739 1
            when CC_System =>
2740 1
               Visit_System_Instance (E);
2741

2742 1
            when CC_Process =>
2743 1
               Visit_Process_Instance (E);
2744

2745 1
            when CC_Thread =>
2746 1
               Visit_Thread_Instance (E);
2747

2748 1
            when others =>
2749 1
               null;
2750 1
         end case;
2751 1
      end Visit_Component_Instance;
2752

2753
      ---------------------------
2754
      -- Visit_Device_Instance --
2755
      ---------------------------
2756

2757 1
      procedure Visit_Device_Instance (E : Node_Id) is
2758 1
         Implementation : constant Node_Id := Get_Implementation (E);
2759

2760
      begin
2761 1
         if Implementation /= No_Node then
2762

2763
            --  A device may be "implemented" using an abstract
2764
            --  component, representing its driver. We iterate on its
2765
            --  subcomponents to attach specific threads associated.
2766

2767 1
            Visit_Subcomponents_Of (Implementation);
2768
         end if;
2769 1
      end Visit_Device_Instance;
2770

2771
      ----------------------------
2772
      -- Visit_Process_Instance --
2773
      ----------------------------
2774

2775 1
      procedure Visit_Process_Instance (E : Node_Id) is
2776
         U : constant Node_Id :=
2777 1
           ADN.Distributed_Application_Unit
2778 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
2779 1
         P          : constant Node_Id := ADN.Entity (U);
2780 1
         S          : Node_Id;
2781 1
         N          : Node_Id;
2782
         The_System : constant Node_Id :=
2783 1
           Parent_Component (Parent_Subcomponent (E));
2784

2785
      begin
2786 1
         Push_Entity (P);
2787 1
         Push_Entity (U);
2788 1
         Set_Job_Body;
2789

2790
         --  Start recording the handling since they have to be reset
2791
         --  for each node.
2792

2793 1
         Start_Recording_Handlings;
2794

2795
         --  Reset hybrid thread related global variables
2796

2797 1
         Has_Hybrid_Threads       := False;
2798 1
         Hybrid_Thread_Elements   := No_List;
2799 1
         Last_Hybrid_Thread_Index := 0;
2800

2801
         --  Initialize the runtime routine list
2802

2803 1
         Interrogation_Routine_List := New_List (ADN.K_Statement_List);
2804

2805
         --  Visit all the subcomponents of the process
2806

2807 1
         if not AINU.Is_Empty (Subcomponents (E)) then
2808 1
            S := First_Node (Subcomponents (E));
2809 1
            while Present (S) loop
2810
               --  Visit the component instance corresponding to the
2811
               --  subcomponent S.
2812

2813 1
               Visit (Corresponding_Instance (S));
2814 1
               S := Next_Node (S);
2815 1
            end loop;
2816
         end if;
2817

2818
         --  Append the runtime routines
2819

2820 1
         Append_Node_To_List
2821 1
           (ADN.First_Node (Interrogation_Routine_List),
2822 1
            ADN.Statements (Current_Package));
2823

2824 1
         if Has_Hybrid_Threads then
2825
            declare
2826 1
               Profile : constant List_Id := New_List (ADN.K_List_Id);
2827
            begin
2828 1
               pragma Assert (not Is_Empty (Hybrid_Thread_Elements));
2829

2830
               N :=
2831 1
                 Message_Comment
2832
                   ("In order for them to work correctly," &
2833
                    " hybrid task need the presence of" &
2834
                    " a driver task to trigger them at" &
2835
                    " their period");
2836 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2837

2838
               --  Declare the hybrid task set
2839

2840
               N :=
2841 1
                 Make_Object_Declaration
2842
                   (Defining_Identifier =>
2843 1
                      Make_Defining_Identifier (PN (P_Hybrid_Task_Set)),
2844 1
                    Object_Definition => RE (RE_Hybrid_Task_Info_Array),
2845
                    Expression        =>
2846 1
                      Make_Array_Aggregate (Hybrid_Thread_Elements));
2847 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2848

2849
               --  Instantiate the hybrid task driver
2850

2851 1
               N := Make_Defining_Identifier (PN (P_Hybrid_Task_Set));
2852 1
               Append_Node_To_List (N, Profile);
2853

2854 1
               N := Make_Attribute_Designator (RE (RE_Priority), A_Last);
2855 1
               Append_Node_To_List (N, Profile);
2856

2857 1
               N := Make_Literal (New_Integer_Value (128_000, 1, 10));
2858 1
               Append_Node_To_List (N, Profile);
2859

2860 1
               N := RE (RE_Deliver);
2861 1
               Append_Node_To_List (N, Profile);
2862

2863
               N :=
2864 1
                 Make_Package_Instantiation
2865 1
                   (Make_Defining_Identifier (PN (P_Hybrid_Task_Driver)),
2866 1
                    RU (RU_PolyORB_HI_Hybrid_Task_Driver_Driver),
2867
                    Profile);
2868 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2869

2870
               N :=
2871 1
                 Make_Pragma_Statement
2872
                   (Pragma_Unreferenced,
2873 1
                    Make_List_Id
2874 1
                      (Make_Defining_Identifier (PN (P_Hybrid_Task_Driver))));
2875 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2876
            end;
2877
         end if;
2878

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

2882 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
2883 1
            S := First_Node (Subcomponents (The_System));
2884 1
            while Present (S) loop
2885 1
               if AAU.Is_Device (Corresponding_Instance (S))
2886
                 and then
2887 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
2888 1
                   Get_Bound_Processor (E)
2889
               then
2890 1
                  Visit_Device_Instance (Corresponding_Instance (S));
2891
               end if;
2892 1
               S := Next_Node (S);
2893 1
            end loop;
2894
         end if;
2895

2896
         --  Unmark all the marked types
2897

2898 1
         Reset_Handlings;
2899

2900 1
         Pop_Entity; -- U
2901 1
         Pop_Entity; -- P
2902 1
      end Visit_Process_Instance;
2903

2904
      ---------------------------
2905
      -- Visit_System_Instance --
2906
      ---------------------------
2907

2908 1
      procedure Visit_System_Instance (E : Node_Id) is
2909
      begin
2910 1
         Push_Entity (Ada_Root);
2911

2912
         --  Visit all the subcomponents of the system
2913

2914 1
         Visit_Subcomponents_Of (E);
2915

2916 1
         Pop_Entity; --  Ada_Root
2917 1
      end Visit_System_Instance;
2918

2919
      ---------------------------
2920
      -- Visit_Thread_Instance --
2921
      ---------------------------
2922

2923 1
      procedure Visit_Thread_Instance (E : Node_Id) is
2924
         P : constant Supported_Thread_Dispatch_Protocol :=
2925 1
           Get_Thread_Dispatch_Protocol (E);
2926 1
         S : constant Node_Id := Parent_Subcomponent (E);
2927 1
         N : Node_Id;
2928
      begin
2929 1
         case P is
2930 1
            when Thread_Periodic =>
2931 1
               N :=
2932 1
                 Message_Comment
2933 1
                   ("Periodic task : " &
2934 1
                    Get_Name_String (Display_Name (Identifier (S))));
2935 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2936

2937 1
            when Thread_Sporadic =>
2938 1
               N :=
2939 1
                 Message_Comment
2940 1
                   ("Sporadic task : " &
2941 1
                    Get_Name_String (Display_Name (Identifier (S))));
2942 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2943

2944 0
            when Thread_Aperiodic =>
2945 0
               N :=
2946 0
                 Message_Comment
2947 0
                   ("Aperiodic task : " &
2948 0
                    Get_Name_String (Display_Name (Identifier (S))));
2949 0
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2950

2951 1
            when Thread_Background =>
2952 1
               N :=
2953 1
                 Message_Comment
2954 1
                   ("Background task : " &
2955 1
                    Get_Name_String (Display_Name (Identifier (S))));
2956 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2957

2958 0
            when Thread_ISR =>
2959 0
               N :=
2960 0
                 Message_Comment
2961 0
                   ("ISR task : " &
2962 0
                    Get_Name_String (Display_Name (Identifier (S))));
2963 0
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2964

2965 1
            when Thread_Hybrid =>
2966 1
               N :=
2967 1
                 Message_Comment
2968 1
                   ("Hybrid task : " &
2969 1
                    Get_Name_String (Display_Name (Identifier (S))));
2970 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2971

2972
               --  Hybrid threads requires an extra driver thread to be
2973
               --  created.
2974

2975
               declare
2976 1
                  Aggr : constant List_Id := New_List (ADN.K_Component_List);
2977
               begin
2978 1
                  Has_Hybrid_Threads := True;
2979

2980 1
                  if Hybrid_Thread_Elements = No_List then
2981 1
                     Hybrid_Thread_Elements := New_List (ADN.K_Element_List);
2982
                  end if;
2983

2984
                  --  Append the element association corresponding to
2985
                  --  E to the hybrid task set.
2986

2987 1
                  N := Extract_Enumerator (E);
2988 1
                  Append_Node_To_List (N, Aggr);
2989

2990
                  --  We know that the last node added to the feature
2991
                  --  list of E is the one appended at expansion time
2992
                  --  and corresponding to the fake event port that
2993
                  --  will receive the dispatch messages from the
2994
                  --  driver.
2995

2996 1
                  N := Extract_Enumerator (Last_Node (Features (E)));
2997 1
                  Append_Node_To_List (N, Aggr);
2998

2999 1
                  N := Map_Ada_Time (Get_Thread_Period (E));
3000 1
                  Append_Node_To_List (N, Aggr);
3001

3002 1
                  N := RE (RE_Time_First);
3003 1
                  Append_Node_To_List (N, Aggr);
3004

3005 1
                  N := RE (RE_True);
3006 1
                  Append_Node_To_List (N, Aggr);
3007

3008
                  N :=
3009 1
                    Make_Qualified_Expression
3010 1
                      (RE (RE_Hybrid_Task_Info),
3011 1
                       Make_Record_Aggregate (Aggr));
3012

3013 1
                  Last_Hybrid_Thread_Index := Last_Hybrid_Thread_Index + 1;
3014

3015
                  N :=
3016 1
                    Make_Element_Association
3017 1
                      (Make_Literal
3018 1
                         (New_Integer_Value (Last_Hybrid_Thread_Index, 1, 10)),
3019
                       N);
3020 1
                  Append_Node_To_List (N, Hybrid_Thread_Elements);
3021
               end;
3022

3023 0
            when others =>
3024 0
               raise Program_Error;
3025 1
         end case;
3026

3027
         declare
3028
            Activate_Entrypoint : constant Name_Id :=
3029 1
              Get_Thread_Activate_Entrypoint (E);
3030
         begin
3031
            --  If the thread has been assigned an initialize
3032
            --  entrypoint, we complete the subprogram renaming
3033
            --  initiated in the spec.
3034

3035 1
            if Activate_Entrypoint /= No_Name then
3036
               N :=
3037 1
                 Make_Subprogram_Specification
3038 1
                   (Defining_Identifier => Map_Task_Init_Identifier (E),
3039
                    Parameter_Profile   => No_List,
3040
                    Return_Type         => No_Node,
3041
                    Renamed_Subprogram  =>
3042 1
                      Map_Ada_Subprogram_Identifier (Activate_Entrypoint));
3043 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
3044
            end if;
3045
         end;
3046

3047
         declare
3048
            Rec_Entrypoint : constant Name_Id :=
3049 1
              Get_Thread_Recover_Entrypoint (E);
3050
         begin
3051
            --  If the thread has been assigned a recover
3052
            --  entrypoint, we complete the subprogram renaming
3053
            --  initiated in the spec.
3054

3055 1
            if Rec_Entrypoint /= No_Name then
3056
               N :=
3057 1
                 Make_Subprogram_Specification
3058 1
                   (Defining_Identifier => Map_Task_Recover_Identifier (E),
3059
                    Parameter_Profile   => No_List,
3060
                    Return_Type         => No_Node,
3061
                    Renamed_Subprogram  =>
3062 1
                      Map_Ada_Subprogram_Identifier (Rec_Entrypoint));
3063 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
3064
            end if;
3065
         end;
3066

3067 1
         if Has_Modes (E) then
3068
            --  If the thread has operational modes, then generate the
3069
            --  body of the mode updater procedure and the global
3070
            --  variable designating the current mode. there is no
3071
            --  harm using a global variable because
3072
            --  it is accessed exclusively by the thread.
3073
            --  We also with a package instance of teh corresponding
3074
            --  scheduler
3075

3076 1
            N := Make_Current_Mode_Declaration (E);
3077 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
3078

3079 1
            if Is_Fusioned (E) then
3080

3081 0
               N := Make_Mode_Updater_body (E);
3082 0
               Append_Node_To_List (N, ADN.Statements (Current_Package));
3083

3084
               N :=
3085 0
                 Make_Withed_Package
3086 0
                   (Make_Defining_Identifier
3087 0
                      (Map_Scheduler_Instance_Name (E)));
3088 0
               Append_Node_To_List (N, ADN.Withed_Packages (Current_Package));
3089
            end if;
3090
         end if;
3091

3092
         --  Create the body of the parameterless subprogram that
3093
         --  executes the thread job.
3094
         --
3095
         --  Note it is added in the Interrogation_Routine_List to
3096
         --  avoid issues with Ada 2012 freezing rules.
3097

3098 1
         N := Task_Job_Body (E);
3099 1
         Append_Node_To_List (N, Interrogation_Routine_List);
3100 1
      end Visit_Thread_Instance;
3101

3102
      ----------------------------
3103
      -- Make_Mode_Updater_Body --
3104
      ----------------------------
3105

3106 0
      function Make_Mode_Updater_body (E : Node_Id) return Node_Id is
3107 0
         N    : Node_Id;
3108
         Spec : constant Node_Id :=
3109 0
           Backend_Node (Identifier (First_Node (Modes (E))));
3110 0
         Stats : constant List_Id := New_List (ADN.K_List_Id);
3111
      begin
3112
         N :=
3113 0
           Make_Assignment_Statement
3114
             (Variable_Identifier => Current_Mode_Identifier,
3115 0
              Expression          => Make_Defining_Identifier (PN (P_Mode)));
3116 0
         Append_Node_To_List (N, Stats);
3117 0
         N := Make_Subprogram_Implementation (Spec, No_List, Stats);
3118 0
         return N;
3119
      end Make_Mode_Updater_body;
3120

3121
   end Package_Body;
3122

3123 1
end Ocarina.Backends.PO_HI_Ada.Job;

Read our documentation on viewing source code .

Loading