ocarina-backends-mast-main.adb 13.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
------------------------------------------------------------------------------
--                                                                          --
--                           OCARINA COMPONENTS                             --
--                                                                          --
--           O C A R I N A . B A C K E N D S . M A S T . M A I N            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2010, European Space Agency (ESA).              --
--                                                                          --
-- Ocarina  is free software;  you  can  redistribute  it and/or  modify    --
-- it under terms of the GNU General Public License as published by the     --
-- Free Software Foundation; either version 2, or (at your option) any      --
-- later version. Ocarina is distributed  in  the  hope  that it will be    --
-- useful, but WITHOUT ANY WARRANTY;  without even the implied warranty of  --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received  a copy of the --
-- GNU General Public License distributed with Ocarina; see file COPYING.   --
-- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02111-1301, USA.                                       --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable to be   --
-- covered  by the  GNU  General  Public  License. This exception does not  --
-- however invalidate  any other reasons why the executable file might be   --
-- covered by the GNU Public License.                                       --
--                                                                          --
--                 Ocarina is maintained by the Ocarina team                --
--                       (ocarina-users@listes.enst.fr)                     --
--                                                                          --
------------------------------------------------------------------------------

34
35
with Namet; use Namet;

36
37
38
39
40
41
with Ocarina.ME_AADL;
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.ME_AADL.AADL_Instances.Nutils;
with Ocarina.ME_AADL.AADL_Instances.Entities;
with Ocarina.Backends.MAST_Tree.Nodes;
with Ocarina.Backends.MAST_Tree.Nutils;
julien.delange's avatar
julien.delange committed
42
with Ocarina.Backends.MAST_Values;
julien.delange's avatar
julien.delange committed
43
44
with Ocarina.Backends.Properties;
with Ocarina.Backends.Utils;
45
46
47
48
49
50
51

package body Ocarina.Backends.MAST.Main is

   use Ocarina.ME_AADL;
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
   use Ocarina.ME_AADL.AADL_Instances.Entities;
   use Ocarina.Backends.MAST_Tree.Nutils;
julien.delange's avatar
julien.delange committed
52
53
   use Ocarina.Backends.Utils;
   use Ocarina.Backends.Properties;
julien.delange's avatar
julien.delange committed
54
   use Ocarina.Backends.MAST_Values;
55

julien.delange's avatar
julien.delange committed
56
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
57
58
59
60
61
62
63
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
   package MTN renames Ocarina.Backends.MAST_Tree.Nodes;
   package MTU renames Ocarina.Backends.MAST_Tree.Nutils;

   procedure Visit_Component (E : Node_Id);
   procedure Visit_System (E : Node_Id);
   procedure Visit_Processor (E : Node_Id);
julien.delange's avatar
julien.delange committed
64
65
   procedure Visit_Process (E : Node_Id);
   procedure Visit_Thread (E : Node_Id);
julien.delange's avatar
julien.delange committed
66
   procedure Visit_Subprogram (E : Node_Id);
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
   procedure Visit_Bus (E : Node_Id);
   procedure Visit_Virtual_Processor (E : Node_Id);

   Root_System_Node                 : Node_Id := No_Node;

   -----------
   -- Visit --
   -----------

   procedure Visit (E : Node_Id) is
   begin
      case Kind (E) is
         when K_Architecture_Instance =>
            Root_System_Node := Root_System (E);
            Visit (Root_System_Node);

         when K_Component_Instance =>
            Visit_Component (E);

         when others =>
            null;
      end case;
   end Visit;

   ---------------------
   -- Visit_Component --
   ---------------------

   procedure Visit_Component (E : Node_Id) is
      Category : constant Component_Category
        := Get_Category_Of_Component (E);
   begin
      case Category is
         when CC_System =>
            Visit_System (E);

         when CC_Processor =>
            Visit_Processor (E);

julien.delange's avatar
julien.delange committed
106
107
108
         when CC_Subprogram =>
            Visit_Subprogram (E);

julien.delange's avatar
julien.delange committed
109
110
111
112
113
114
         when CC_Process =>
            Visit_Process (E);

         when CC_Thread =>
            Visit_Thread (E);

115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
         when CC_Bus =>
            Visit_Bus (E);

         when CC_Virtual_Processor =>
            Visit_Virtual_Processor (E);

         when others =>
            null;
      end case;
   end Visit_Component;

   ---------------
   -- Visit_Bus --
   ---------------

   procedure Visit_Bus (E : Node_Id) is
      pragma Unreferenced (E);
   begin
      null;
   end Visit_Bus;

   --------------------------------------
   -- Visit_Virtual_Processor_Instance --
   --------------------------------------

   procedure Visit_Virtual_Processor (E : Node_Id) is
      pragma Unreferenced (E);
   begin
      null;
   end Visit_Virtual_Processor;

   ---------------------
   -- Visit_Processor --
   ---------------------

   procedure Visit_Processor (E : Node_Id) is
      S        : Node_Id;
      N        : Node_Id;
   begin
      N := MTU.Make_Processing_Resource
julien.delange's avatar
julien.delange committed
155
         (Normalize_Name (Name (Identifier (E))),
156
         PR_Fixed_Priority_Processor);
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

      MTU.Append_Node_To_List (N, MTN.Declarations (MAST_File));

      if not AINU.Is_Empty (Subcomponents (E)) then
         S := First_Node (Subcomponents (E));
         while Present (S) loop
            --  Visit the component instance corresponding to the
            --  subcomponent S.

            Visit (Corresponding_Instance (S));
            S := Next_Node (S);
         end loop;
      end if;
   end Visit_Processor;

julien.delange's avatar
julien.delange committed
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
   -------------------
   -- Visit_Process --
   -------------------

   procedure Visit_Process (E : Node_Id) is
      S        : Node_Id;
   begin
      if not AINU.Is_Empty (Subcomponents (E)) then
         S := First_Node (Subcomponents (E));
         while Present (S) loop
            --  Visit the component instance corresponding to the
            --  subcomponent S.

            Visit (Corresponding_Instance (S));
            S := Next_Node (S);
         end loop;
      end if;
   end Visit_Process;

   ------------------
   -- Visit_Thread --
   ------------------

   procedure Visit_Thread (E : Node_Id) is
196
197
      S                       : Node_Id;
      N                       : Node_Id;
julien.delange's avatar
julien.delange committed
198
199
200
      Call                    : Node_Id;
      Spg_Call                : Node_Id;
      Spg                     : Node_Id;
201
202
203
204
205
206
      Activation_Event        : Node_Id;
      Activation_Kind         : Event_Kind := Regular;
      Activation_Event_Name   : Name_Id;
      Output_Event            : Node_Id;
      Output_Event_Name       : Name_Id;
      Event_Handler           : Node_Id;
207
      Server_Parameters       : Node_Id;
208
209
210
      Server_Sched_Name       : Name_Id;
      Operation_Name          : Name_Id;
      Operation               : Node_Id;
julien.delange's avatar
julien.delange committed
211
212
213
      Operations_List         : constant List_Id
                  := MTU.New_List (MTN.K_List_Id);
      Output_Event_Req        : Node_Id := No_Node;
214
      Prio                    : Unsigned_Long_Long;
julien.delange's avatar
julien.delange committed
215
   begin
216
217
218
219
220
221
222
223
224
225
      Set_Str_To_Name_Buffer ("");
      Get_Name_String (Normalize_Name (Name (Identifier (E))));
      Add_Str_To_Name_Buffer ("_operations");
      Operation_Name := Name_Find;

      Set_Str_To_Name_Buffer ("");
      Get_Name_String (Normalize_Name (Name (Identifier (E))));
      Add_Str_To_Name_Buffer ("_sched_server");
      Server_Sched_Name := Name_Find;

226
227
228
229
230
231
232
      Prio := Get_Thread_Priority (E);
      if Prio = 0 then
         Prio := 1;
      end if;
      Server_Parameters := Make_Scheduling_Server_Parameters
         (Fixed_Priority, Prio);

julien.delange's avatar
julien.delange committed
233
      N := Make_Scheduling_Server
234
         (Server_Sched_Name,
julien.delange's avatar
julien.delange committed
235
236
          Normalize_Name (Name (Identifier (Get_Bound_Processor
          (Parent_Component (Parent_Subcomponent (E)))))));
237
238
239

      MTN.Set_Parameters (N, Server_Parameters);

julien.delange's avatar
julien.delange committed
240
241
      Append_Node_To_List (N, MTN.Declarations (MAST_File));

242
243
244
245
246
247
248
249
250
251
252
      N := Make_Transaction
         (Normalize_Name (Name (Identifier (E))), Regular);
      Append_Node_To_List (N, MTN.Declarations (MAST_File));

      Set_Str_To_Name_Buffer ("");
      Get_Name_String (Normalize_Name (Name (Identifier (E))));
      Add_Str_To_Name_Buffer ("_activation_event");
      Activation_Event_Name := Name_Find;

      if Get_Thread_Dispatch_Protocol (E) = Thread_Periodic then
         Activation_Kind := Periodic;
julien.delange's avatar
julien.delange committed
253
254
255
256
257
258

         Output_Event_Req
            := Make_Event_Timing_Requirement
               (Hard_Deadline,
               To_Milliseconds (Get_Thread_Deadline (E)),
               Activation_Event_Name);
259
260
261
262
263
264
265
266
      elsif Get_Thread_Dispatch_Protocol (E) = Thread_Sporadic then
         Activation_Kind := Sporadic;
      else
         Activation_Kind := Regular;
      end if;

      Activation_Event := Make_Event (Activation_Event_Name, Activation_Kind);

julien.delange's avatar
julien.delange committed
267
268
269
270
271
272
273
274
275
276
      if Get_Thread_Dispatch_Protocol (E) = Thread_Periodic then
         MTN.Set_Period
            (Activation_Event,
            Make_Literal
               (New_Numeric_Value
                  (To_Milliseconds (Get_Thread_Period (E)), 1, 10)));
      else
         MTN.Set_Period (Activation_Event, No_Node);
      end if;

277
278
279
280
281
282
283
284
285
286
      Append_Node_To_List
         (Activation_Event, MTN.External_Events (N));

      Set_Str_To_Name_Buffer ("");
      Get_Name_String (Normalize_Name (Name (Identifier (E))));
      Add_Str_To_Name_Buffer ("_output_event");
      Output_Event_Name := Name_Find;

      Output_Event := Make_Event (Output_Event_Name, Regular);

julien.delange's avatar
julien.delange committed
287
288
      MTN.Set_Timing_Requirements (Output_Event, Output_Event_Req);

289
290
291
292
293
294
295
296
297
298
299
300
301
302
      Append_Node_To_List
         (Output_Event, MTN.Internal_Events (N));

      Event_Handler := Make_Event_Handler
         (Activity,
         Activation_Event_Name,
         Output_Event_Name,
         Operation_Name,
         Server_Sched_Name);

      Append_Node_To_List
         (Event_Handler, MTN.Event_Handlers (N));

      Operation := Make_Operation (Operation_Name, Enclosing);
julien.delange's avatar
julien.delange committed
303
304
      MTN.Set_Operations (Operation, Operations_List);

305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
      if Get_Execution_Time (E) /= Empty_Time_Array then
         declare
            ET : constant Time_Array := Get_Execution_Time (E);
         begin
            MTN.Set_Best_Case_Execution_Time
               (Operation,
               Make_Literal
                  (New_Numeric_Value
                     (To_Milliseconds (ET (0)), 1, 10)));
            MTN.Set_Worst_Case_Execution_Time
               (Operation,
               Make_Literal
                  (New_Numeric_Value
                     (To_Milliseconds (ET (1)), 1, 10)));
         end;
      end if;

322
323
      Append_Node_To_List (Operation, MTN.Declarations (MAST_File));

julien.delange's avatar
julien.delange committed
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
      if not AINU.Is_Empty (Calls (E)) then
         Call := AIN.First_Node (Calls (E));
         while Present (Call) loop

            if not AINU.Is_Empty (Subprogram_Calls (Call)) then
               Spg_Call := AIN.First_Node
                  (AIN.Subprogram_Calls (Call));
               while Present (Spg_Call) loop

                  Spg := AIN.Corresponding_Instance (Spg_Call);
                  Append_Node_To_List
                     (Make_Defining_Identifier
                        (Name (Identifier (Spg))),
                     Operations_List);
                  Visit (Spg);
                  Spg_Call := AIN.Next_Node (Spg_Call);
               end loop;
            end if;
            Call := AIN.Next_Node (Call);
         end loop;
      end if;

julien.delange's avatar
julien.delange committed
346
347
348
349
350
351
352
353
354
355
356
357
      if not AINU.Is_Empty (Subcomponents (E)) then
         S := First_Node (Subcomponents (E));
         while Present (S) loop
            --  Visit the component instance corresponding to the
            --  subcomponent S.

            Visit (Corresponding_Instance (S));
            S := Next_Node (S);
         end loop;
      end if;
   end Visit_Thread;

julien.delange's avatar
julien.delange committed
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
   ----------------------
   -- Visit_Subprogram --
   ----------------------

   procedure Visit_Subprogram (E : Node_Id) is
      Operation               : Node_Id;
      Operation_Name          : Name_Id;
      Operations_List         : constant List_Id
                  := MTU.New_List (MTN.K_List_Id);
   begin
      Operation_Name := Name (Identifier (E));
      Operation := Make_Operation (Operation_Name, Simple);
      MTN.Set_Operations (Operation, Operations_List);

      Append_Node_To_List (Operation, MTN.Declarations (MAST_File));
   end Visit_Subprogram;

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
   ------------------
   -- Visit_System --
   ------------------

   procedure Visit_System (E : Node_Id) is
      S                    : Node_Id;
   begin
      if not AINU.Is_Empty (Subcomponents (E)) then
         S := First_Node (Subcomponents (E));
         while Present (S) loop
            --  Visit the component instance corresponding to the
            --  subcomponent S.
            Visit (Corresponding_Instance (S));
            S := Next_Node (S);
         end loop;
      end if;
   end Visit_System;
end Ocarina.Backends.MAST.Main;