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 . M A I N       --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2006-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.Namet; use Ocarina.Namet;
34
with Ocarina.ME_AADL;
35
with Ocarina.ME_AADL.AADL_Instances.Nodes;
36
with Ocarina.ME_AADL.AADL_Instances.Nutils;
37
with Ocarina.ME_AADL.AADL_Instances.Entities;
38
with Ocarina.Backends.PO_HI_Ada.Mapping;
39
use Ocarina.Backends.PO_HI_Ada.Mapping;
40

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

48
package body Ocarina.Backends.PO_HI_Ada.Main is
49

50
   use Ocarina.ME_AADL;
51
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
52
   use Ocarina.ME_AADL.AADL_Instances.Entities;
53
   use Ocarina.Backends.Utils;
54
   use Ocarina.Backends.Properties;
55
   use Ocarina.Backends.Ada_Tree.Nutils;
56
   use Ocarina.Backends.PO_HI_Ada.Runtime;
57
   use Ocarina.Backends.Messages;
58

59
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
60
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
61
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
62

63
   ---------------------
64
   -- Subprogram_Body --
65
   ---------------------
66

67
   package body Subprogram_Body is
68

69
      procedure Visit_Architecture_Instance (E : Node_Id);
70
      procedure Visit_Component_Instance (E : Node_Id);
71
      procedure Visit_System_Instance (E : Node_Id);
72
      procedure Visit_Process_Instance (E : Node_Id);
73
      procedure Visit_Thread_Instance (E : Node_Id);
74
      procedure Visit_Device_Instance (E : Node_Id);
75

76
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
77

78
      Has_Hybrid_Threads : Boolean := False;
79

80
      -----------
81
      -- Visit --
82
      -----------
83

84 1
      procedure Visit (E : Node_Id) is
85
      begin
86 1
         case Kind (E) is
87 1
            when K_Architecture_Instance =>
88 1
               Visit_Architecture_Instance (E);
89

90 1
            when K_Component_Instance =>
91 1
               Visit_Component_Instance (E);
92

93 0
            when others =>
94 0
               null;
95 1
         end case;
96 1
      end Visit;
97

98
      ---------------------------------
99
      -- Visit_Architecture_Instance --
100
      ---------------------------------
101

102 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
103
      begin
104 1
         Visit (Root_System (E));
105 1
      end Visit_Architecture_Instance;
106

107
      ------------------------------
108
      -- Visit_Component_Instance --
109
      ------------------------------
110

111 1
      procedure Visit_Component_Instance (E : Node_Id) is
112
         Category : constant Component_Category :=
113 1
           Get_Category_Of_Component (E);
114
      begin
115 1
         case Category is
116 1
            when CC_System =>
117 1
               Visit_System_Instance (E);
118

119 1
            when CC_Process =>
120 1
               Visit_Process_Instance (E);
121

122 1
            when CC_Thread =>
123 1
               Visit_Thread_Instance (E);
124

125 1
            when others =>
126 1
               null;
127 1
         end case;
128 1
      end Visit_Component_Instance;
129

130
      ---------------------------
131
      -- Visit_Device_Instance --
132
      ---------------------------
133

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

138
         function Get_Bus (Device : Node_Id) return Node_Id;
139

140 1
         function Get_Bus (Device : Node_Id) return Node_Id is
141 1
            The_System : Node_Id;
142 1
            S          : Node_Id;
143
         begin
144
            The_System :=
145 1
              Parent_Component
146 1
                (Parent_Subcomponent
147 1
                   (Corresponding_Instance (Parent_Subcomponent (Device))));
148

149 1
            pragma Assert (AINU.Is_System (The_System));
150

151 1
            if not AAU.Is_Empty (Connections (The_System)) then
152 1
               S := First_Node (Connections (The_System));
153

154
               --  Check whether a device is attached to this bus
155

156 1
               while Present (S) loop
157 1
                  if Kind (S) = K_Connection_Instance
158 1
                    and then (Get_Category_Of_Connection (S) = CT_Access_Bus
159
                                or else
160 0
                                Get_Category_Of_Connection (S) = CT_Access)
161
                  then
162
                     if True
163
                        --  This device is connected to the bus
164

165
                       and then
166 1
                         Parent_Subcomponent (Device) =
167 1
                         Item (First_Node (Path (Destination (S))))
168
                     then
169
                        --  Note, for now, we assume there is only one
170
                        --  device at each end of the bus.
171

172 1
                        return Item (First_Node (Path (Source (S))));
173
                     end if;
174
                  end if;
175 1
                  S := Next_Node (S);
176 1
               end loop;
177
            end if;
178

179 0
            return No_Node;
180
         end Get_Bus;
181

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

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

201
      ----------------------------
202
      -- Visit_Process_Instance --
203
      ----------------------------
204

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

221
         --  Check that the process has indeed an execution platform
222

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

233
         --  Reset hybrid thread related global variables
234

235 1
         Has_Hybrid_Threads := False;
236

237
         --  Visit all the subcomponents of the process
238

239 1
         Visit_Subcomponents_Of (E);
240

241 1
         if Has_Hybrid_Threads then
242
            --  Unblock the hybrid task driver
243

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

251
         --  Declarative part
252

253
         N :=
254 1
           Make_Pragma_Statement
255
             (Pragma_Priority,
256 1
              Make_List_Id
257 1
                (Make_Attribute_Designator (RE (RE_Priority), A_Last)));
258 1
         Append_Node_To_List (N, ADN.Declarations (Current_Package));
259

260
         --  Statements
261

262
         --  Initialize default transport, if any
263

264 1
         if Transport_API /= Transport_None
265 0
           and then Transport_API /= Transport_User
266
         then
267
            N :=
268 0
              Message_Comment ("Initialize default communication subsystem");
269 0
            Append_Node_To_List (N, ADN.Statements (Current_Package));
270

271 0
            N := Make_Subprogram_Call (RE (RE_Initialize), No_List);
272 0
            Append_Node_To_List (N, ADN.Statements (Current_Package));
273
         end if;
274

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

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

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

295 1
         N := Make_Subprogram_Call (RE (RE_Unblock_All_Tasks));
296 1
         Append_Node_To_List (N, ADN.Statements (Current_Package));
297

298
         --  Suspend forever the main task
299

300
         N :=
301 1
           Message_Comment
302
             ("Suspend forever instead of putting an" &
303
              " endless loop. This saves the CPU" &
304
              " resources.");
305 1
         Append_Node_To_List (N, ADN.Statements (Current_Package));
306

307 1
         N := Make_Subprogram_Call (RE (RE_Suspend_Forever));
308 1
         Append_Node_To_List (N, ADN.Statements (Current_Package));
309

310 1
         Pop_Entity; -- U
311 1
         Pop_Entity; -- P
312 1
      end Visit_Process_Instance;
313

314
      ---------------------------
315
      -- Visit_System_Instance --
316
      ---------------------------
317

318 1
      procedure Visit_System_Instance (E : Node_Id) is
319
      begin
320 1
         Push_Entity (Ada_Root);
321

322 1
         Visit_Subcomponents_Of (E);
323

324 1
         Pop_Entity; --  Ada_Root
325 1
      end Visit_System_Instance;
326

327
      ---------------------------
328
      -- Visit_Thread_Instance --
329
      ---------------------------
330

331 1
      procedure Visit_Thread_Instance (E : Node_Id) is
332
         P : constant Supported_Thread_Dispatch_Protocol :=
333 1
           Get_Thread_Dispatch_Protocol (E);
334
      begin
335 1
         case P is
336 1
            when Thread_Periodic |
337
              Thread_Sporadic    |
338
              Thread_Hybrid      |
339
              Thread_Aperiodic   |
340
              Thread_Background  |
341
              Thread_ISR         =>
342

343 1
               if Has_Ports (E) then
344 1
                  Add_With_Package
345 1
                    (E => RU (RU_PolyORB_HI_Generated_Activity, False),
346
                     Used         => False,
347
                     Warnings_Off => True,
348
                     Elaborated   => True);
349
               end if;
350

351 1
               Add_With_Package
352 1
                 (E            => RU (Ru_Polyorb_Hi_Generated_Job, False),
353
                  Used         => False,
354
                  Warnings_Off => True,
355
                  Elaborated   => True);
356

357 1
               if P = Thread_Hybrid then
358 1
                  Has_Hybrid_Threads := True;
359
               end if;
360

361
               declare
362
                  Initialize_Entrypoint : constant Name_Id :=
363 1
                    Get_Thread_Initialize_Entrypoint (E);
364 1
                  N : Node_Id;
365
               begin
366 1
                  if Initialize_Entrypoint /= No_Name then
367 1
                     N :=
368 1
                       Message_Comment
369 1
                         ("Initialize thread " &
370 1
                          Get_Name_String
371 1
                            (Name
372 1
                               (Identifier
373 1
                                  (Corresponding_Instance
374 1
                                     (Parent_Subcomponent (E))))));
375

376 1
                     Append_Node_To_List (N, ADN.Statements (Current_Package));
377

378
                     N :=
379 1
                       Make_Subprogram_Call
380 1
                         (Map_Ada_Subprogram_Identifier
381
                            (Initialize_Entrypoint),
382
                          No_List);
383 1
                     Append_Node_To_List (N, ADN.Statements (Current_Package));
384
                  end if;
385
               end;
386

387 0
            when others =>
388 0
               raise Program_Error;
389 1
         end case;
390 1
      end Visit_Thread_Instance;
391

392
   end Subprogram_Body;
393

394
end Ocarina.Backends.PO_HI_Ada.Main;

Read our documentation on viewing source code .

Loading