OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-tasatt.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                        GNAT RUN-TIME COMPONENTS                          --
4
--                                                                          --
5
--                  A D A . T A S K _ A T T R I B U T E S                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--             Copyright (C) 1991-1994, Florida State University            --
10
--                     Copyright (C) 1995-2010, AdaCore                     --
11
--                                                                          --
12
-- GNAT is free software;  you can  redistribute it  and/or modify it 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.  GNAT is distributed in the hope that it will be useful, but WITH- --
16
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17
-- 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
-- GNARL was developed by the GNARL team at Florida State University.       --
29
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
30
--                                                                          --
31
------------------------------------------------------------------------------
32
 
33
--  The following notes are provided in case someone decides the implementation
34
--  of this package is too complicated, or too slow. Please read this before
35
--  making any "simplifications".
36
 
37
--  Correct implementation of this package is more difficult than one might
38
--  expect. After considering (and coding) several alternatives, we settled on
39
--  the present compromise. Things we do not like about this implementation
40
--  include:
41
 
42
--  - It is vulnerable to bad Task_Id values, to the extent of possibly
43
--    trashing memory and crashing the runtime system.
44
 
45
--  - It requires dynamic storage allocation for each new attribute value,
46
--    except for types that happen to be the same size as System.Address, or
47
--    shorter.
48
 
49
--  - Instantiations at other than the library level rely on being able to
50
--    do down-level calls to a procedure declared in the generic package body.
51
--    This makes it potentially vulnerable to compiler changes.
52
 
53
--  The main implementation issue here is that the connection from task to
54
--  attribute is a potential source of dangling references.
55
 
56
--  When a task goes away, we want to be able to recover all the storage
57
--  associated with its attributes. The Ada mechanism for this is finalization,
58
--  via controlled attribute types. For this reason, the ARM requires
59
--  finalization of attribute values when the associated task terminates.
60
 
61
--  This finalization must be triggered by the tasking runtime system, during
62
--  termination of the task. Given the active set of instantiations of
63
--  Ada.Task_Attributes is dynamic, the number and types of attributes
64
--  belonging to a task will not be known until the task actually terminates.
65
--  Some of these types may be controlled and some may not. The RTS must find
66
--  some way to determine which of these attributes need finalization, and
67
--  invoke the appropriate finalization on them.
68
 
69
--  One way this might be done is to create a special finalization chain for
70
--  each task, similar to the finalization chain that is used for controlled
71
--  objects within the task. This would differ from the usual finalization
72
--  chain in that it would not have a LIFO structure, since attributes may be
73
--  added to a task at any time during its lifetime. This might be the right
74
--  way to go for the longer term, but at present this approach is not open,
75
--  since GNAT does not provide such special finalization support.
76
 
77
--  Lacking special compiler support, the RTS is limited to the normal ways an
78
--  application invokes finalization, i.e.
79
 
80
--  a) Explicit call to the procedure Finalize, if we know the type has this
81
--     operation defined on it. This is not sufficient, since we have no way
82
--     of determining whether a given generic formal Attribute type is
83
--     controlled, and no visibility of the associated Finalize procedure, in
84
--     the generic body.
85
 
86
--  b) Leaving the scope of a local object of a controlled type. This does not
87
--     help, since the lifetime of an instantiation of Ada.Task_Attributes
88
--     does not correspond to the lifetimes of the various tasks which may
89
--     have that attribute.
90
 
91
--  c) Assignment of another value to the object. This would not help, since
92
--     we then have to finalize the new value of the object.
93
 
94
--  d) Unchecked deallocation of an object of a controlled type. This seems to
95
--     be the only mechanism available to the runtime system for finalization
96
--     of task attributes.
97
 
98
--  We considered two ways of using unchecked deallocation, both based on a
99
--  linked list of that would hang from the task control block.
100
 
101
--  In the first approach the objects on the attribute list are all derived
102
--  from one controlled type, say T, and are linked using an access type to
103
--  T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class
104
--  with access type T'Class, and uses this to deallocate and finalize all the
105
--  items in the list. The limitation of this approach is that each
106
--  instantiation of the package Ada.Task_Attributes derives a new record
107
--  extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is
108
--  only allowed at the library level.
109
 
110
--  In the second approach the objects on the attribute list are of unrelated
111
--  but structurally similar types. Unchecked conversion is used to circument
112
--  Ada type checking. Each attribute-storage node contains not only the
113
--  attribute value and a link for chaining, but also a pointer to descriptor
114
--  for the corresponding instantiation of Task_Attributes. The instantiation
115
--  descriptor contains pointer to a procedure that can do the correct
116
--  deallocation and finalization for that type of attribute. On task
117
--  termination, the runtime system uses the pointer to call the appropriate
118
--  deallocator.
119
 
120
--  While this gets around the limitation that instantations be at the library
121
--  level, it relies on an implementation feature that may not always be safe,
122
--  i.e. that it is safe to call the Deallocate procedure for an instantiation
123
--  of Ada.Task_Attributes that no longer exists. In general, it seems this
124
--  might result in dangling references.
125
 
126
--  Another problem with instantiations deeper than the library level is that
127
--  there is risk of storage leakage, or dangling references to reused storage.
128
--  That is, if an instantiation of Ada.Task_Attributes is made within a
129
--  procedure, what happens to the storage allocated for attributes, when the
130
--  procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be
131
--  finalized, since they will no longer be accessible, and in general one
132
--  would expect that the storage they occupy would be recovered for later
133
--  reuse. (If not, we would have a case of storage leakage.) Assuming the
134
--  storage is recovered and later reused, we have potentially dangerous
135
--  dangling references. When the procedure containing the instantiation of
136
--  Ada.Task_Attributes returns, there may still be unterminated tasks with
137
--  associated attribute values for that instantiation. When such tasks
138
--  eventually terminate, the RTS will attempt to call the Deallocate procedure
139
--  on them. If the corresponding storage has already been deallocated, when
140
--  the master of the access type was left, we have a potential disaster. This
141
--  disaster is compounded since the pointer to Deallocate is probably through
142
--  a "trampoline" which will also have been destroyed.
143
 
144
--  For this reason, we arrange to remove all dangling references before
145
--  leaving the scope of an instantiation. This is ugly, since it requires
146
--  traversing the list of all tasks, but it is no more ugly than a similar
147
--  traversal that we must do at the point of instantiation in order to
148
--  initialize the attributes of all tasks. At least we only need to do these
149
--  traversals if the type is controlled.
150
 
151
--  We chose to defer allocation of storage for attributes until the Reference
152
--  function is called or the attribute is first set to a value different from
153
--  the default initial one. This allows a potential savings in allocation,
154
--  for attributes that are not used by all tasks.
155
 
156
--  For efficiency, we reserve space in the TCB for a fixed number of direct-
157
--  access attributes. These are required to be of a size that fits in the
158
--  space of an object of type System.Address. Because we must use unchecked
159
--  bitwise copy operations on these values, they cannot be of a controlled
160
--  type, but that is covered automatically since controlled objects are too
161
--  large to fit in the spaces.
162
 
163
--  We originally deferred initialization of these direct-access attributes,
164
--  just as we do for the indirect-access attributes, and used a per-task bit
165
--  vector to keep track of which attributes were currently defined for that
166
--  task. We found that the overhead of maintaining this bit-vector seriously
167
--  slowed down access to the attributes, and made the fetch operation non-
168
--  atomic, so that even to read an attribute value required locking the TCB.
169
--  Therefore, we now initialize such attributes for all existing tasks at the
170
--  time of the attribute instantiation, and initialize existing attributes for
171
--  each new task at the time it is created.
172
 
173
--  The latter initialization requires a list of all the instantiation
174
--  descriptors. Updates to this list, as well as the bit-vector that is used
175
--  to reserve slots for attributes in the TCB, require mutual exclusion. That
176
--  is provided by the Lock/Unlock_RTS.
177
 
178
--  One special problem that added complexity to the design is that the per-
179
--  task list of indirect attributes contains objects of different types. We
180
--  use unchecked pointer conversion to link these nodes together and access
181
--  them, but the records may not have identical internal structure. Initially,
182
--  we thought it would be enough to allocate all the common components of
183
--  the records at the front of each record, so that their positions would
184
--  correspond. Unfortunately, GNAT adds "dope" information at the front
185
--  of a record, if the record contains any controlled-type components.
186
--
187
--  This means that the offset of the fields we use to link the nodes is at
188
--  different positions on nodes of different types. To get around this, each
189
--  attribute storage record consists of a core node and wrapper. The core
190
--  nodes are all of the same type, and it is these that are linked together
191
--  and generally "seen" by the RTS. Each core node contains a pointer to its
192
--  own wrapper, which is a record that contains the core node along with an
193
--  attribute value, approximately as follows:
194
 
195
--    type Node;
196
--    type Node_Access is access all Node;
197
--    type Wrapper;
198
--    type Access_Wrapper is access all Wrapper;
199
--    type Node is record
200
--       Next    : Node_Access;
201
--       ...
202
--       Wrapper : Access_Wrapper;
203
--    end record;
204
--    type Wrapper is record
205
--       Dummy_Node : aliased Node;
206
--       Value      : aliased Attribute;  --  the generic formal type
207
--    end record;
208
 
209
--  Another interesting problem is with the initialization of the instantiation
210
--  descriptors. Originally, we did this all via the Initialize procedure of
211
--  the descriptor type and code in the package body. It turned out that the
212
--  Initialize procedure needed quite a bit of information, including the size
213
--  of the attribute type, the initial value of the attribute (if it fits in
214
--  the TCB), and a pointer to the deallocator procedure. These needed to be
215
--  "passed" in via access discriminants. GNAT was having trouble with access
216
--  discriminants, so all this work was moved to the package body.
217
 
218
--  Note that references to objects declared in this package body must in
219
--  general use 'Unchecked_Access instead of 'Access as the package can be
220
--  instantiated from within a local context.
221
 
222
with System.Storage_Elements;
223
with System.Task_Primitives.Operations;
224
with System.Tasking;
225
with System.Tasking.Initialization;
226
with System.Tasking.Task_Attributes;
227
 
228
with Ada.Exceptions;
229
with Ada.Unchecked_Conversion;
230
with Ada.Unchecked_Deallocation;
231
 
232
pragma Elaborate_All (System.Tasking.Task_Attributes);
233
--  To ensure the initialization of object Local (below) will work
234
 
235
package body Ada.Task_Attributes is
236
 
237
   use System.Tasking.Initialization,
238
       System.Tasking,
239
       System.Tasking.Task_Attributes,
240
       Ada.Exceptions;
241
 
242
   package POP renames System.Task_Primitives.Operations;
243
 
244
   ---------------------------
245
   -- Unchecked Conversions --
246
   ---------------------------
247
 
248
   --  The following type corresponds to Dummy_Wrapper, declared in
249
   --  System.Tasking.Task_Attributes.
250
 
251
   type Wrapper;
252
   type Access_Wrapper is access all Wrapper;
253
 
254
   pragma Warnings (Off);
255
   --  We turn warnings off for the following To_Attribute_Handle conversions,
256
   --  since these are used only for small attributes where we know that there
257
   --  are no problems with alignment, but the compiler will generate warnings
258
   --  for the occurrences in the large attribute case, even though they will
259
   --  not actually be used.
260
 
261
   function To_Attribute_Handle is new Ada.Unchecked_Conversion
262
     (System.Address, Attribute_Handle);
263
   function To_Direct_Attribute_Element is new Ada.Unchecked_Conversion
264
     (System.Address, Direct_Attribute_Element);
265
   --  For reference to directly addressed task attributes
266
 
267
   type Access_Integer_Address is access all
268
     System.Storage_Elements.Integer_Address;
269
 
270
   function To_Attribute_Handle is new Ada.Unchecked_Conversion
271
     (Access_Integer_Address, Attribute_Handle);
272
   --  For reference to directly addressed task attributes
273
 
274
   pragma Warnings (On);
275
   --  End warnings off region for directly addressed attribute conversions
276
 
277
   function To_Access_Address is new Ada.Unchecked_Conversion
278
     (Access_Node, Access_Address);
279
   --  To store pointer to list of indirect attributes
280
 
281
   pragma Warnings (Off);
282
   function To_Access_Wrapper is new Ada.Unchecked_Conversion
283
     (Access_Dummy_Wrapper, Access_Wrapper);
284
   pragma Warnings (On);
285
   --  To fetch pointer to actual wrapper of attribute node. We turn off
286
   --  warnings since this may generate an alignment warning. The warning can
287
   --  be ignored since Dummy_Wrapper is only a non-generic standin for the
288
   --  real wrapper type (we never actually allocate objects of type
289
   --  Dummy_Wrapper).
290
 
291
   function To_Access_Dummy_Wrapper is new Ada.Unchecked_Conversion
292
     (Access_Wrapper, Access_Dummy_Wrapper);
293
   --  To store pointer to actual wrapper of attribute node
294
 
295
   function To_Task_Id is new Ada.Unchecked_Conversion
296
     (Task_Identification.Task_Id, Task_Id);
297
   --  To access TCB of identified task
298
 
299
   type Local_Deallocator is access procedure (P : in out Access_Node);
300
 
301
   function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion
302
     (Local_Deallocator, Deallocator);
303
   --  To defeat accessibility check
304
 
305
   ------------------------
306
   -- Storage Management --
307
   ------------------------
308
 
309
   procedure Deallocate (P : in out Access_Node);
310
   --  Passed to the RTS via unchecked conversion of a pointer to permit
311
   --  finalization and deallocation of attribute storage nodes.
312
 
313
   --------------------------
314
   -- Instantiation Record --
315
   --------------------------
316
 
317
   Local : aliased Instance;
318
   --  Initialized in package body
319
 
320
   type Wrapper is record
321
      Dummy_Node : aliased Node;
322
 
323
      Value : aliased Attribute := Initial_Value;
324
      --  The generic formal type, may be controlled
325
   end record;
326
 
327
   --  A number of unchecked conversions involving Wrapper_Access sources are
328
   --  performed in this unit. We have to ensure that the designated object is
329
   --  always strictly enough aligned.
330
 
331
   for Wrapper'Alignment use Standard'Maximum_Alignment;
332
 
333
   procedure Free is
334
      new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper);
335
 
336
   procedure Deallocate (P : in out Access_Node) is
337
      T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
338
   begin
339
      Free (T);
340
   end Deallocate;
341
 
342
   ---------------
343
   -- Reference --
344
   ---------------
345
 
346
   function Reference
347
     (T    : Task_Identification.Task_Id := Task_Identification.Current_Task)
348
      return Attribute_Handle
349
   is
350
      TT            : constant Task_Id := To_Task_Id (T);
351
      Error_Message : constant String  := "Trying to get the reference of a ";
352
 
353
   begin
354
      if TT = null then
355
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
356
      end if;
357
 
358
      if TT.Common.State = Terminated then
359
         Raise_Exception (Tasking_Error'Identity,
360
           Error_Message & "terminated task");
361
      end if;
362
 
363
      --  Directly addressed case
364
 
365
      if Local.Index /= 0 then
366
 
367
         --  Return the attribute handle. Warnings off because this return
368
         --  statement generates alignment warnings for large attributes
369
         --  (but will never be executed in this case anyway).
370
 
371
         pragma Warnings (Off);
372
         return
373
           To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
374
         pragma Warnings (On);
375
 
376
      --  Not directly addressed
377
 
378
      else
379
         declare
380
            P       : Access_Node := To_Access_Node (TT.Indirect_Attributes);
381
            W       : Access_Wrapper;
382
            Self_Id : constant Task_Id := POP.Self;
383
 
384
         begin
385
            Defer_Abort (Self_Id);
386
            POP.Lock_RTS;
387
 
388
            while P /= null loop
389
               if P.Instance = Access_Instance'(Local'Unchecked_Access) then
390
                  POP.Unlock_RTS;
391
                  Undefer_Abort (Self_Id);
392
                  return To_Access_Wrapper (P.Wrapper).Value'Access;
393
               end if;
394
 
395
               P := P.Next;
396
            end loop;
397
 
398
            --  Unlock the RTS here to follow the lock ordering rule that
399
            --  prevent us from using new (i.e the Global_Lock) while holding
400
            --  any other lock.
401
 
402
            POP.Unlock_RTS;
403
            W := new Wrapper'
404
                  ((null, Local'Unchecked_Access, null), Initial_Value);
405
            POP.Lock_RTS;
406
 
407
            P := W.Dummy_Node'Unchecked_Access;
408
            P.Wrapper := To_Access_Dummy_Wrapper (W);
409
            P.Next := To_Access_Node (TT.Indirect_Attributes);
410
            TT.Indirect_Attributes := To_Access_Address (P);
411
            POP.Unlock_RTS;
412
            Undefer_Abort (Self_Id);
413
            return W.Value'Access;
414
 
415
         exception
416
            when others =>
417
               POP.Unlock_RTS;
418
               Undefer_Abort (Self_Id);
419
               raise;
420
         end;
421
      end if;
422
 
423
   exception
424
      when Tasking_Error | Program_Error =>
425
         raise;
426
 
427
      when others =>
428
         raise Program_Error;
429
   end Reference;
430
 
431
   ------------------
432
   -- Reinitialize --
433
   ------------------
434
 
435
   procedure Reinitialize
436
     (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
437
   is
438
      TT            : constant Task_Id := To_Task_Id (T);
439
      Error_Message : constant String  := "Trying to Reinitialize a ";
440
 
441
   begin
442
      if TT = null then
443
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
444
      end if;
445
 
446
      if TT.Common.State = Terminated then
447
         Raise_Exception (Tasking_Error'Identity,
448
           Error_Message & "terminated task");
449
      end if;
450
 
451
      if Local.Index /= 0 then
452
         Set_Value (Initial_Value, T);
453
      else
454
         declare
455
            P, Q    : Access_Node;
456
            W       : Access_Wrapper;
457
            Self_Id : constant Task_Id := POP.Self;
458
 
459
         begin
460
            Defer_Abort (Self_Id);
461
            POP.Lock_RTS;
462
            Q := To_Access_Node (TT.Indirect_Attributes);
463
 
464
            while Q /= null loop
465
               if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
466
                  if P = null then
467
                     TT.Indirect_Attributes := To_Access_Address (Q.Next);
468
                  else
469
                     P.Next := Q.Next;
470
                  end if;
471
 
472
                  W := To_Access_Wrapper (Q.Wrapper);
473
                  Free (W);
474
                  POP.Unlock_RTS;
475
                  Undefer_Abort (Self_Id);
476
                  return;
477
               end if;
478
 
479
               P := Q;
480
               Q := Q.Next;
481
            end loop;
482
 
483
            POP.Unlock_RTS;
484
            Undefer_Abort (Self_Id);
485
 
486
         exception
487
            when others =>
488
               POP.Unlock_RTS;
489
               Undefer_Abort (Self_Id);
490
               raise;
491
         end;
492
      end if;
493
 
494
   exception
495
      when Tasking_Error | Program_Error =>
496
         raise;
497
 
498
      when others =>
499
         raise Program_Error;
500
   end Reinitialize;
501
 
502
   ---------------
503
   -- Set_Value --
504
   ---------------
505
 
506
   procedure Set_Value
507
     (Val : Attribute;
508
      T   : Task_Identification.Task_Id := Task_Identification.Current_Task)
509
   is
510
      TT            : constant Task_Id := To_Task_Id (T);
511
      Error_Message : constant String  := "Trying to Set the Value of a ";
512
 
513
   begin
514
      if TT = null then
515
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
516
      end if;
517
 
518
      if TT.Common.State = Terminated then
519
         Raise_Exception (Tasking_Error'Identity,
520
           Error_Message & "terminated task");
521
      end if;
522
 
523
      --  Directly addressed case
524
 
525
      if Local.Index /= 0 then
526
 
527
         --  Set attribute handle, warnings off, because this code can generate
528
         --  alignment warnings with large attributes (but of course will not
529
         --  be executed in this case, since we never have direct addressing in
530
         --  such cases).
531
 
532
         pragma Warnings (Off);
533
         To_Attribute_Handle
534
            (TT.Direct_Attributes (Local.Index)'Address).all := Val;
535
         pragma Warnings (On);
536
         return;
537
      end if;
538
 
539
      --  Not directly addressed
540
 
541
      declare
542
         P       : Access_Node := To_Access_Node (TT.Indirect_Attributes);
543
         W       : Access_Wrapper;
544
         Self_Id : constant Task_Id := POP.Self;
545
 
546
      begin
547
         Defer_Abort (Self_Id);
548
         POP.Lock_RTS;
549
 
550
         while P /= null loop
551
 
552
            if P.Instance = Access_Instance'(Local'Unchecked_Access) then
553
               To_Access_Wrapper (P.Wrapper).Value := Val;
554
               POP.Unlock_RTS;
555
               Undefer_Abort (Self_Id);
556
               return;
557
            end if;
558
 
559
            P := P.Next;
560
         end loop;
561
 
562
         --  Unlock RTS here to follow the lock ordering rule that prevent us
563
         --  from using new (i.e the Global_Lock) while holding any other lock.
564
 
565
         POP.Unlock_RTS;
566
         W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
567
         POP.Lock_RTS;
568
         P := W.Dummy_Node'Unchecked_Access;
569
         P.Wrapper := To_Access_Dummy_Wrapper (W);
570
         P.Next := To_Access_Node (TT.Indirect_Attributes);
571
         TT.Indirect_Attributes := To_Access_Address (P);
572
 
573
         POP.Unlock_RTS;
574
         Undefer_Abort (Self_Id);
575
 
576
      exception
577
         when others =>
578
            POP.Unlock_RTS;
579
            Undefer_Abort (Self_Id);
580
            raise;
581
      end;
582
 
583
   exception
584
      when Tasking_Error | Program_Error =>
585
         raise;
586
 
587
      when others =>
588
         raise Program_Error;
589
   end Set_Value;
590
 
591
   -----------
592
   -- Value --
593
   -----------
594
 
595
   function Value
596
     (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
597
      return Attribute
598
   is
599
      TT            : constant Task_Id := To_Task_Id (T);
600
      Error_Message : constant String  := "Trying to get the Value of a ";
601
 
602
   begin
603
      if TT = null then
604
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
605
      end if;
606
 
607
      if TT.Common.State = Terminated then
608
         Raise_Exception
609
           (Program_Error'Identity, Error_Message & "terminated task");
610
      end if;
611
 
612
      --  Directly addressed case
613
 
614
      if Local.Index /= 0 then
615
 
616
         --  Get value of attribute. We turn Warnings off, because for large
617
         --  attributes, this code can generate alignment warnings. But of
618
         --  course large attributes are never directly addressed so in fact
619
         --  we will never execute the code in this case.
620
 
621
         pragma Warnings (Off);
622
         return To_Attribute_Handle
623
           (TT.Direct_Attributes (Local.Index)'Address).all;
624
         pragma Warnings (On);
625
      end if;
626
 
627
      --  Not directly addressed
628
 
629
      declare
630
         P       : Access_Node;
631
         Result  : Attribute;
632
         Self_Id : constant Task_Id := POP.Self;
633
 
634
      begin
635
         Defer_Abort (Self_Id);
636
         POP.Lock_RTS;
637
         P := To_Access_Node (TT.Indirect_Attributes);
638
 
639
         while P /= null loop
640
            if P.Instance = Access_Instance'(Local'Unchecked_Access) then
641
               Result := To_Access_Wrapper (P.Wrapper).Value;
642
               POP.Unlock_RTS;
643
               Undefer_Abort (Self_Id);
644
               return Result;
645
            end if;
646
 
647
            P := P.Next;
648
         end loop;
649
 
650
         POP.Unlock_RTS;
651
         Undefer_Abort (Self_Id);
652
         return Initial_Value;
653
 
654
      exception
655
         when others =>
656
            POP.Unlock_RTS;
657
            Undefer_Abort (Self_Id);
658
            raise;
659
      end;
660
 
661
   exception
662
      when Tasking_Error | Program_Error =>
663
         raise;
664
 
665
      when others =>
666
         raise Program_Error;
667
   end Value;
668
 
669
--  Start of elaboration code for package Ada.Task_Attributes
670
 
671
begin
672
   --  This unchecked conversion can give warnings when alignments are
673
   --  incorrect, but they will not be used in such cases anyway, so the
674
   --  warnings can be safely ignored.
675
 
676
   pragma Warnings (Off);
677
   Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
678
   pragma Warnings (On);
679
 
680
   declare
681
      Two_To_J : Direct_Index_Vector;
682
      Self_Id  : constant Task_Id := POP.Self;
683
   begin
684
      Defer_Abort (Self_Id);
685
 
686
      --  Need protection for updating links to per-task initialization and
687
      --  finalization routines, in case some task is being created or
688
      --  terminated concurrently.
689
 
690
      POP.Lock_RTS;
691
 
692
      --  Add this instantiation to the list of all instantiations
693
 
694
      Local.Next := System.Tasking.Task_Attributes.All_Attributes;
695
      System.Tasking.Task_Attributes.All_Attributes :=
696
        Local'Unchecked_Access;
697
 
698
      --  Try to find space for the attribute in the TCB
699
 
700
      Local.Index := 0;
701
      Two_To_J := 1;
702
 
703
      if Attribute'Size <= System.Address'Size then
704
         for J in Direct_Index_Range loop
705
            if (Two_To_J and In_Use) = 0 then
706
 
707
               --  Reserve location J for this attribute
708
 
709
               In_Use := In_Use or Two_To_J;
710
               Local.Index := J;
711
 
712
               --  This unchecked conversion can give a warning when the
713
               --  alignment is incorrect, but it will not be used in such
714
               --  a case anyway, so the warning can be safely ignored.
715
 
716
               pragma Warnings (Off);
717
               To_Attribute_Handle (Local.Initial_Value'Access).all :=
718
                 Initial_Value;
719
               pragma Warnings (On);
720
 
721
               exit;
722
            end if;
723
 
724
            Two_To_J := Two_To_J * 2;
725
         end loop;
726
      end if;
727
 
728
      --  Attribute goes directly in the TCB
729
 
730
      if Local.Index /= 0 then
731
         --  Replace stub for initialization routine that is called at task
732
         --  creation.
733
 
734
         Initialization.Initialize_Attributes_Link :=
735
           System.Tasking.Task_Attributes.Initialize_Attributes'Access;
736
 
737
         --  Initialize the attribute, for all tasks
738
 
739
         declare
740
            C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
741
         begin
742
            while C /= null loop
743
               C.Direct_Attributes (Local.Index) :=
744
                 To_Direct_Attribute_Element
745
                   (System.Storage_Elements.To_Address (Local.Initial_Value));
746
               C := C.Common.All_Tasks_Link;
747
            end loop;
748
         end;
749
 
750
      --  Attribute goes into a node onto a linked list
751
 
752
      else
753
         --  Replace stub for finalization routine called at task termination
754
 
755
         Initialization.Finalize_Attributes_Link :=
756
           System.Tasking.Task_Attributes.Finalize_Attributes'Access;
757
      end if;
758
 
759
      POP.Unlock_RTS;
760
      Undefer_Abort (Self_Id);
761
   end;
762
end Ada.Task_Attributes;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.