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

33
with Ocarina.Instances;
34
with Ocarina.Backends.Messages;
35
with Ocarina.Backends.Expander;
36
with Ocarina.Backends.XML_Tree.Nodes;
37
with Ocarina.Backends.XML_Tree.Nutils;
38
with Ocarina.Backends.XML_Tree.Generator;
39
with Ocarina.Backends.Properties;
40
with Ocarina.Backends.Utils;
41
with Ocarina.ME_AADL.AADL_Instances.Nodes;
42
with Ocarina.ME_AADL.AADL_Instances.Nutils;
43
with Ocarina.ME_AADL.AADL_Instances.Entities;
44

45
with Ocarina.Instances.Queries;
46

47
with Ocarina.Namet; use Ocarina.Namet;
48

49 1
package body Ocarina.Backends.POK_Cheddar is
50

51
   use Ocarina.Instances;
52

53
   use Ocarina.Backends.Expander;
54
   use Ocarina.Backends.Messages;
55
   use Ocarina.Backends.Properties;
56
   use Ocarina.Backends.Utils;
57
   use Ocarina.ME_AADL;
58
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
59
   use Ocarina.ME_AADL.AADL_Instances.Entities;
60
   use Ocarina.Backends.XML_Tree.Nutils;
61

62
   use Ocarina.Instances.Queries;
63

64
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
65
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
66
   package XTN renames Ocarina.Backends.XML_Tree.Nodes;
67
   package XTU renames Ocarina.Backends.XML_Tree.Nutils;
68

69
   procedure Visit (E : Node_Id);
70
   procedure Visit_Component_Instance (E : Node_Id);
71
   procedure Visit_System_Instance (E : Node_Id);
72
   procedure Visit_Processor_Instance (E : Node_Id);
73
   procedure Visit_Virtual_Processor_Instance (E : Node_Id);
74
   procedure Visit_Process_Instance (E : Node_Id);
75
   procedure Visit_Thread_Instance (E : Node_Id);
76

77
   Task_Id                   : Unsigned_Long_Long := 0;
78 1
   Current_System            : Node_Id;
79 1
   Current_Virtual_Processor : Node_Id;
80 1
   Current_Process           : Node_Id;
81 1
   Current_Processor         : Node_Id;
82

83
   ----------------
84
   -- Map_Thread --
85
   ----------------
86

87 1
   procedure Map_Thread (E : Node_Id) is
88 1
      N   : Node_Id;
89 1
      L   : Node_Id;
90 1
      R   : Node_Id;
91 1
      Tmp : Name_Id;
92
   begin
93
      --  Delete the space introduced by Ada.
94 1
      Set_Str_To_Name_Buffer (Unsigned_Long_Long'Image (Task_Id));
95 1
      Set_Str_To_Name_Buffer (Name_Buffer (2 .. Name_Len));
96 1
      Tmp := Name_Find;
97

98 1
      N := Make_XML_Node ("thread");
99

100
      --  Set the pokname attribute.
101 1
      Set_Str_To_Name_Buffer ("pokname");
102 1
      L := Make_Defining_Identifier (Name_Find);
103

104 1
      Set_Str_To_Name_Buffer ("task");
105 1
      Get_Name_String_And_Append (Tmp);
106

107 1
      R := Make_Defining_Identifier (Name_Find);
108

109 1
      Append_Node_To_List (Make_Assignement (L, R), XTN.Items (N));
110

111
      --  Set the aadlprocessor attribute.
112 1
      if Current_Processor /= No_Node then
113 1
         Set_Str_To_Name_Buffer ("aadlprocessor");
114 1
         L := Make_Defining_Identifier (Name_Find);
115

116
         R :=
117 1
           Make_Defining_Identifier
118 1
             (Display_Name
119 1
                (Identifier (Parent_Subcomponent (Current_Processor))));
120

121 1
         Append_Node_To_List (Make_Assignement (L, R), XTN.Items (N));
122
      end if;
123

124
      --  Set the aadlprocess attribute.
125 1
      if Current_Processor /= No_Node then
126 1
         Set_Str_To_Name_Buffer ("aadlprocess");
127 1
         L := Make_Defining_Identifier (Name_Find);
128

129
         R :=
130 1
           Make_Defining_Identifier
131 1
             (Display_Name
132 1
                (Identifier (Parent_Subcomponent (Current_Process))));
133

134 1
         Append_Node_To_List (Make_Assignement (L, R), XTN.Items (N));
135
      end if;
136

137
      --  Set the aadlvirtualprocessor attribute.
138 1
      if Current_Processor /= No_Node then
139 1
         Set_Str_To_Name_Buffer ("aadlvirtualprocessor");
140 1
         L := Make_Defining_Identifier (Name_Find);
141

142
         R :=
143 1
           Make_Defining_Identifier
144 1
             (Display_Name
145 1
                (Identifier
146 1
                   (Parent_Subcomponent (Current_Virtual_Processor))));
147

148 1
         Append_Node_To_List (Make_Assignement (L, R), XTN.Items (N));
149
      end if;
150

151
      --  Set the cheddarname attribute.
152 1
      if Current_Processor /= No_Node then
153 1
         Set_Str_To_Name_Buffer ("cheddarname");
154 1
         L := Make_Defining_Identifier (Name_Find);
155

156 1
         Get_Name_String
157 1
           (Display_Name
158 1
              (Identifier (Parent_Subcomponent (Current_Virtual_Processor))));
159

160 1
         Add_Str_To_Name_Buffer (".");
161

162 1
         Get_Name_String_And_Append
163 1
           (Display_Name (Identifier (Parent_Subcomponent (E))));
164

165 1
         R := Make_Defining_Identifier (Name_Find);
166

167 1
         Append_Node_To_List (Make_Assignement (L, R), XTN.Items (N));
168
      end if;
169

170 1
      Append_Node_To_List (N, XTN.Subitems (Current_XML_Node));
171

172 1
      Task_Id := Task_Id + 1;
173 1
   end Map_Thread;
174

175
   -----------------
176
   -- Map_HI_Node --
177
   -----------------
178

179 1
   function Map_HI_Node (E : Node_Id) return Node_Id is
180 1
      N : constant Node_Id := New_Node (XTN.K_HI_Node);
181
   begin
182
      pragma Assert
183 1
        (AINU.Is_Process (E)
184 1
         or else AINU.Is_System (E)
185 1
         or else AINU.Is_Processor (E));
186

187 1
      if AINU.Is_System (E) then
188 0
         Set_Str_To_Name_Buffer ("general");
189
      else
190 1
         Get_Name_String
191 1
           (To_XML_Name
192 1
              (AIN.Name (AIN.Identifier (AIN.Parent_Subcomponent (E)))));
193 1
         Add_Str_To_Name_Buffer ("_pok_cheddar_mapping");
194
      end if;
195

196 1
      XTN.Set_Name (N, Name_Find);
197

198 1
      XTN.Set_Units (N, XTU.New_List (XTN.K_List_Id));
199

200
      --  Append the partition N to the node list
201

202 1
      XTU.Append_Node_To_List (N, XTN.HI_Nodes (Current_Entity));
203 1
      XTN.Set_Distributed_Application (N, Current_Entity);
204

205 1
      return N;
206
   end Map_HI_Node;
207

208
   -----------------
209
   -- Map_HI_Unit --
210
   -----------------
211

212 1
   function Map_HI_Unit (E : Node_Id) return Node_Id is
213 1
      U    : Node_Id;
214 1
      N    : Node_Id;
215 1
      P    : Node_Id;
216 1
      Root : Node_Id;
217
   begin
218
      pragma Assert
219 1
        (AINU.Is_System (E)
220 1
         or else AINU.Is_Process (E)
221 1
         or else AINU.Is_Processor (E));
222

223 1
      U := XTU.New_Node (XTN.K_HI_Unit, AIN.Identifier (E));
224

225
      --  Packages that are common to all nodes
226 1
      Get_Name_String
227 1
        (To_XML_Name (Display_Name (Identifier (Parent_Subcomponent (E)))));
228 1
      Add_Str_To_Name_Buffer ("_pok-mapping");
229 1
      N := XTU.Make_Defining_Identifier (Name_Find);
230 1
      P := XTU.Make_XML_File (N);
231 1
      XTN.Set_Distributed_Application_Unit (P, U);
232 1
      XTN.Set_XML_File (U, P);
233

234 1
      Root := Make_XML_Node ("Mapping_Rules");
235

236 1
      XTN.Set_Root_Node (P, Root);
237

238 1
      Current_XML_Node := Root;
239

240 1
      XTU.Append_Node_To_List (U, XTN.Units (Current_Entity));
241 1
      XTN.Set_Entity (U, Current_Entity);
242

243 1
      return U;
244
   end Map_HI_Unit;
245

246
   --------------
247
   -- Generate --
248
   --------------
249

250 0
   procedure Generate (AADL_Root : Node_Id) is
251 0
      Instance_Root : Node_Id;
252
   begin
253

254 0
      Instance_Root := Instantiate_Model (AADL_Root);
255

256 0
      Expand (Instance_Root);
257

258 0
      Visit_Architecture_Instance (Instance_Root);
259
      --  Abort if the construction of the C tree failed
260

261 0
      if No (XML_Root) then
262 0
         Display_Error ("POK_Cheddar generation failed", Fatal => True);
263
      end if;
264

265
      --  At this point, we have a valid tree, we can begin the XML
266
      --  file generation.
267

268
      --  Enter the output directory
269

270 0
      Enter_Directory (Generated_Sources_Directory);
271

272 0
      if not Remove_Generated_Sources then
273
         --  Create the source files
274

275 0
         XML_Tree.Generator.Generate (XML_Root);
276

277
      end if;
278

279
      --  Leave the output directory
280 0
      Leave_Directory;
281 0
   end Generate;
282

283
   ----------
284
   -- Init --
285
   ----------
286

287 0
   procedure Init is
288
   begin
289 0
      Register_Backend ("POK_Cheddar", Generate'Access, Statistics);
290 0
   end Init;
291

292
   -----------
293
   -- Reset --
294
   -----------
295

296 0
   procedure Reset is
297
   begin
298 0
      null;
299 0
   end Reset;
300

301
   ---------------------------------
302
   -- Visit_Architecture_Instance --
303
   ---------------------------------
304

305 1
   procedure Visit_Architecture_Instance (E : Node_Id) is
306
   begin
307 1
      XML_Root := XTU.New_Node (XTN.K_HI_Distributed_Application);
308 1
      Set_Str_To_Name_Buffer ("generated-code");
309 1
      XTN.Set_Name (XML_Root, Name_Find);
310 1
      XTN.Set_Units (XML_Root, XTU.New_List (XTN.K_List_Id));
311 1
      XTN.Set_HI_Nodes (XML_Root, XTU.New_List (XTN.K_List_Id));
312

313 1
      XTU.Push_Entity (XML_Root);
314

315 1
      Visit (Root_System (E));
316

317 1
      XTU.Pop_Entity;
318

319 1
   end Visit_Architecture_Instance;
320

321
   ------------------
322
   -- Get_XML_Root --
323
   ------------------
324

325 1
   function Get_XML_Root return Node_Id is
326
   begin
327 1
      return XML_Root;
328
   end Get_XML_Root;
329

330
   -----------
331
   -- Visit --
332
   -----------
333

334 1
   procedure Visit (E : Node_Id) is
335
   begin
336 1
      case Kind (E) is
337 0
         when K_Architecture_Instance =>
338 0
            Visit_Architecture_Instance (E);
339

340 1
         when K_Component_Instance =>
341 1
            Visit_Component_Instance (E);
342

343 0
         when others =>
344 0
            null;
345 1
      end case;
346 1
   end Visit;
347

348
   ------------------------------
349
   -- Visit_Component_Instance --
350
   ------------------------------
351

352 1
   procedure Visit_Component_Instance (E : Node_Id) is
353 1
      Category : constant Component_Category := Get_Category_Of_Component (E);
354
   begin
355 1
      case Category is
356 1
         when CC_System =>
357 1
            Visit_System_Instance (E);
358

359 1
         when CC_Thread =>
360 1
            Visit_Thread_Instance (E);
361

362 1
         when CC_Process =>
363 1
            Visit_Process_Instance (E);
364

365 1
         when CC_Processor =>
366 1
            Visit_Processor_Instance (E);
367

368 1
         when CC_Virtual_Processor =>
369 1
            Visit_Virtual_Processor_Instance (E);
370

371 0
         when others =>
372 0
            null;
373 1
      end case;
374 1
   end Visit_Component_Instance;
375

376
   ----------------------------
377
   -- Visit_Process_Instance --
378
   ----------------------------
379

380 1
   procedure Visit_Process_Instance (E : Node_Id) is
381 1
      S : Node_Id;
382
   begin
383 1
      Current_Process := E;
384

385 1
      if not AINU.Is_Empty (Subcomponents (E)) then
386 1
         S := First_Node (Subcomponents (E));
387 1
         while Present (S) loop
388
            --  Visit the component instance corresponding to the
389
            --  subcomponent S.
390

391 1
            Visit (Corresponding_Instance (S));
392 1
            S := Next_Node (S);
393 1
         end loop;
394
      end if;
395

396 1
      Current_Process := No_Node;
397 1
   end Visit_Process_Instance;
398

399
   ---------------------------
400
   -- Visit_Thread_Instance --
401
   ---------------------------
402

403 1
   procedure Visit_Thread_Instance (E : Node_Id) is
404 1
      S : Node_Id;
405
   begin
406 1
      Map_Thread (E);
407

408 1
      if not AINU.Is_Empty (Subcomponents (E)) then
409 0
         S := First_Node (Subcomponents (E));
410 0
         while Present (S) loop
411
            --  Visit the component instance corresponding to the
412
            --  subcomponent S.
413

414 0
            Visit (Corresponding_Instance (S));
415 0
            S := Next_Node (S);
416 0
         end loop;
417
      end if;
418 1
   end Visit_Thread_Instance;
419

420
   ---------------------------
421
   -- Visit_System_Instance --
422
   ---------------------------
423

424 1
   procedure Visit_System_Instance (E : Node_Id) is
425 1
      S : Node_Id;
426
   begin
427 1
      Current_System := E;
428

429 1
      if not AINU.Is_Empty (Subcomponents (E)) then
430 1
         S := First_Node (Subcomponents (E));
431 1
         while Present (S) loop
432
            --  Visit the component instance corresponding to the
433
            --  subcomponent S.
434 1
            if AINU.Is_Processor (Corresponding_Instance (S)) then
435 1
               Visit (Corresponding_Instance (S));
436
            end if;
437 1
            S := Next_Node (S);
438 1
         end loop;
439
      end if;
440 1
   end Visit_System_Instance;
441

442
   ------------------------------
443
   -- Visit_Processor_Instance --
444
   ------------------------------
445

446 1
   procedure Visit_Processor_Instance (E : Node_Id) is
447 1
      S : Node_Id;
448 1
      U : Node_Id;
449 1
      P : Node_Id;
450
   begin
451 1
      Current_Processor := E;
452

453 1
      P := Map_HI_Node (E);
454 1
      Push_Entity (P);
455

456 1
      U := Map_HI_Unit (E);
457 1
      Push_Entity (U);
458

459 1
      Current_XML_Node := XTN.Root_Node (XTN.XML_File (U));
460

461 1
      if not AINU.Is_Empty (Subcomponents (E)) then
462 1
         S := First_Node (Subcomponents (E));
463 1
         while Present (S) loop
464
            --  Visit the component instance corresponding to the
465
            --  subcomponent S.
466

467 1
            Visit (Corresponding_Instance (S));
468 1
            S := Next_Node (S);
469 1
         end loop;
470
      end if;
471

472 1
      Current_Processor := No_Node;
473

474 1
      Pop_Entity;
475 1
      Pop_Entity;
476 1
   end Visit_Processor_Instance;
477

478
   --------------------------------------
479
   -- Visit_Virtual_Processor_Instance --
480
   --------------------------------------
481

482 1
   procedure Visit_Virtual_Processor_Instance (E : Node_Id) is
483 1
      S       : Node_Id;
484 1
      Process : Node_Id;
485
   begin
486 1
      Current_Virtual_Processor := E;
487

488 1
      if not AINU.Is_Empty (Subcomponents (E)) then
489 0
         S := First_Node (Subcomponents (E));
490 0
         while Present (S) loop
491
            --  Visit the component instance corresponding to the
492
            --  subcomponent S.
493

494 0
            Visit (Corresponding_Instance (S));
495 0
            S := Next_Node (S);
496 0
         end loop;
497
      end if;
498

499 1
      if not AINU.Is_Empty (Subcomponents (Current_System)) then
500 1
         S := First_Node (Subcomponents (Current_System));
501 1
         while Present (S) loop
502
            --  Visit the component instance corresponding to the
503
            --  subcomponent S.
504

505 1
            if AINU.Is_Process (Corresponding_Instance (S)) then
506 1
               Process := Corresponding_Instance (S);
507

508 1
               if Get_Bound_Processor (Process) = E then
509
                  --  Visit the partition, we need the init task
510 1
                  Task_Id := Task_Id + 1;
511 1
                  Visit (Process);
512

513 1
                  if Is_Defined_Property (E, "arinc653::hm_errors")
514 1
                    or else Is_Defined_Property (E, "pok::recovery_errors")
515
                  then
516
                     --  If we handle errors, we need to consider the error
517
                     --  recovery task.
518 0
                     Task_Id := Task_Id + 1;
519
                  end if;
520
               end if;
521
            end if;
522 1
            S := Next_Node (S);
523 1
         end loop;
524
      end if;
525

526 1
      Current_Virtual_Processor := No_Node;
527 1
   end Visit_Virtual_Processor_Instance;
528

529 1
end Ocarina.Backends.POK_Cheddar;

Read our documentation on viewing source code .

Loading