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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-soflin.ads] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                    S Y S T E M . S O F T _ L I N K S                     --
6
--                                                                          --
7
--                                 S p e c                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it 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.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- 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
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
--  This package contains a set of subprogram access variables that access
33
--  some low-level primitives that are different depending whether tasking is
34
--  involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a
35
--  different value for each task). To avoid dragging in the tasking runtimes
36
--  all the time, we use a system of soft links where the links are
37
--  initialized to non-tasking versions, and then if the tasking support is
38
--  initialized, they are set to the real tasking versions.
39
 
40
pragma Compiler_Unit;
41
 
42
with Ada.Exceptions;
43
with System.Stack_Checking;
44
 
45
package System.Soft_Links is
46
   pragma Preelaborate_05;
47
 
48
   subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
49
   subtype EO is Ada.Exceptions.Exception_Occurrence;
50
 
51
   function Current_Target_Exception return EO;
52
   pragma Import
53
     (Ada, Current_Target_Exception, "__gnat_current_target_exception");
54
   --  Import this subprogram from the private part of Ada.Exceptions
55
 
56
   --  First we have the access subprogram types used to establish the links.
57
   --  The approach is to establish variables containing access subprogram
58
   --  values, which by default point to dummy no tasking versions of routines.
59
 
60
   type No_Param_Proc     is access procedure;
61
   pragma Favor_Top_Level (No_Param_Proc);
62
   type Addr_Param_Proc   is access procedure (Addr : Address);
63
   pragma Favor_Top_Level (Addr_Param_Proc);
64
   type EO_Param_Proc     is access procedure (Excep : EO);
65
   pragma Favor_Top_Level (EO_Param_Proc);
66
 
67
   type Get_Address_Call  is access function return Address;
68
   pragma Favor_Top_Level (Get_Address_Call);
69
   type Set_Address_Call  is access procedure (Addr : Address);
70
   pragma Favor_Top_Level (Set_Address_Call);
71
   type Set_Address_Call2 is access procedure
72
     (Self_ID : Address; Addr : Address);
73
   pragma Favor_Top_Level (Set_Address_Call2);
74
 
75
   type Get_Integer_Call  is access function return Integer;
76
   pragma Favor_Top_Level (Get_Integer_Call);
77
   type Set_Integer_Call  is access procedure (Len : Integer);
78
   pragma Favor_Top_Level (Set_Integer_Call);
79
 
80
   type Get_EOA_Call      is access function return EOA;
81
   pragma Favor_Top_Level (Get_EOA_Call);
82
   type Set_EOA_Call      is access procedure (Excep : EOA);
83
   pragma Favor_Top_Level (Set_EOA_Call);
84
   type Set_EO_Call       is access procedure (Excep : EO);
85
   pragma Favor_Top_Level (Set_EO_Call);
86
 
87
   type Special_EO_Call   is access
88
     procedure (Excep : EO := Current_Target_Exception);
89
   pragma Favor_Top_Level (Special_EO_Call);
90
 
91
   type Timed_Delay_Call  is access
92
     procedure (Time : Duration; Mode : Integer);
93
   pragma Favor_Top_Level (Timed_Delay_Call);
94
 
95
   type Get_Stack_Access_Call is access
96
     function return Stack_Checking.Stack_Access;
97
   pragma Favor_Top_Level (Get_Stack_Access_Call);
98
 
99
   type Task_Name_Call is access
100
     function return String;
101
   pragma Favor_Top_Level (Task_Name_Call);
102
 
103
   --  Suppress checks on all these types, since we know the corresponding
104
   --  values can never be null (the soft links are always initialized).
105
 
106
   pragma Suppress (Access_Check, No_Param_Proc);
107
   pragma Suppress (Access_Check, Addr_Param_Proc);
108
   pragma Suppress (Access_Check, EO_Param_Proc);
109
   pragma Suppress (Access_Check, Get_Address_Call);
110
   pragma Suppress (Access_Check, Set_Address_Call);
111
   pragma Suppress (Access_Check, Set_Address_Call2);
112
   pragma Suppress (Access_Check, Get_Integer_Call);
113
   pragma Suppress (Access_Check, Set_Integer_Call);
114
   pragma Suppress (Access_Check, Get_EOA_Call);
115
   pragma Suppress (Access_Check, Set_EOA_Call);
116
   pragma Suppress (Access_Check, Timed_Delay_Call);
117
   pragma Suppress (Access_Check, Get_Stack_Access_Call);
118
   pragma Suppress (Access_Check, Task_Name_Call);
119
 
120
   --  The following one is not related to tasking/no-tasking but to the
121
   --  traceback decorators for exceptions.
122
 
123
   type Traceback_Decorator_Wrapper_Call is access
124
     function (Traceback : System.Address;
125
               Len       : Natural)
126
               return      String;
127
   pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call);
128
 
129
   --  Declarations for the no tasking versions of the required routines
130
 
131
   procedure Abort_Defer_NT;
132
   --  Defer task abort (non-tasking case, does nothing)
133
 
134
   procedure Abort_Undefer_NT;
135
   --  Undefer task abort (non-tasking case, does nothing)
136
 
137
   procedure Abort_Handler_NT;
138
   --  Handle task abort (non-tasking case, does nothing). Currently, only VMS
139
   --  uses this.
140
 
141
   procedure Update_Exception_NT (X : EO := Current_Target_Exception);
142
   --  Handle exception setting. This routine is provided for targets that
143
   --  have built-in exception handling such as the Java Virtual Machine.
144
   --  Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on
145
   --  how this routine is used.
146
 
147
   function Check_Abort_Status_NT return Integer;
148
   --  Returns Boolean'Pos (True) iff abort signal should raise
149
   --  Standard.Abort_Signal.
150
 
151
   procedure Task_Lock_NT;
152
   --  Lock out other tasks (non-tasking case, does nothing)
153
 
154
   procedure Task_Unlock_NT;
155
   --  Release lock set by Task_Lock (non-tasking case, does nothing)
156
 
157
   procedure Task_Termination_NT (Excep : EO);
158
   --  Handle task termination routines for the environment task (non-tasking
159
   --  case, does nothing).
160
 
161
   procedure Null_Finalize_Global_List;
162
   --  Finalize global list for controlled objects (does nothing)
163
 
164
   procedure Adafinal_NT;
165
   --  Shuts down the runtime system (non-tasking case)
166
 
167
   Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
168
   pragma Suppress (Access_Check, Abort_Defer);
169
   --  Defer task abort (task/non-task case as appropriate)
170
 
171
   Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
172
   pragma Suppress (Access_Check, Abort_Undefer);
173
   --  Undefer task abort (task/non-task case as appropriate)
174
 
175
   Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
176
   --  Handle task abort (task/non-task case as appropriate)
177
 
178
   Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
179
   --  Handle exception setting and tasking polling when appropriate
180
 
181
   Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
182
   --  Called when Abort_Signal is delivered to the process.  Checks to
183
   --  see if signal should result in raising Standard.Abort_Signal.
184
 
185
   Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
186
   --  Locks out other tasks. Preceding a section of code by Task_Lock and
187
   --  following it by Task_Unlock creates a critical region. This is used
188
   --  for ensuring that a region of non-tasking code (such as code used to
189
   --  allocate memory) is tasking safe. Note that it is valid for calls to
190
   --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
191
   --  only the corresponding outer level Task_Unlock will actually unlock.
192
   --  This routine also prevents against asynchronous aborts (abort is
193
   --  deferred).
194
 
195
   Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
196
   --  Releases lock previously set by call to Lock_Task. In the nested case,
197
   --  all nested locks must be released before other tasks competing for the
198
   --  tasking lock are released.
199
   --
200
   --  In the non nested case, this routine terminates the protection against
201
   --  asynchronous aborts introduced by Lock_Task (unless abort was already
202
   --  deferred before the call to Lock_Task (e.g in a protected procedures).
203
   --
204
   --  Note: the recommended protocol for using Lock_Task and Unlock_Task
205
   --  is as follows:
206
   --
207
   --    Locked_Processing : begin
208
   --       System.Soft_Links.Lock_Task.all;
209
   --       ...
210
   --       System.Soft_Links.Unlock_Task.all;
211
   --
212
   --    exception
213
   --       when others =>
214
   --          System.Soft_Links.Unlock_Task.all;
215
   --          raise;
216
   --    end Locked_Processing;
217
   --
218
   --  This ensures that the lock is not left set if an exception is raised
219
   --  explicitly or implicitly during the critical locked region.
220
 
221
   Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
222
   --  Handle task termination routines (task/non-task case as appropriate)
223
 
224
   Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
225
   --  Performs finalization of global list for controlled objects
226
 
227
   Adafinal : No_Param_Proc := Adafinal_NT'Access;
228
   --  Performs the finalization of the Ada Runtime
229
 
230
   function  Get_Jmpbuf_Address_NT return  Address;
231
   procedure Set_Jmpbuf_Address_NT (Addr : Address);
232
 
233
   Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
234
   Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
235
 
236
   function  Get_Sec_Stack_Addr_NT return  Address;
237
   procedure Set_Sec_Stack_Addr_NT (Addr : Address);
238
 
239
   Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
240
   Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
241
 
242
   function Get_Exc_Stack_Addr_NT return Address;
243
   Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
244
 
245
   function Get_Current_Excep_NT return EOA;
246
 
247
   Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
248
 
249
   function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
250
 
251
   Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
252
 
253
   --------------------------
254
   -- Master_Id Soft-Links --
255
   --------------------------
256
 
257
   --  Soft-Links are used for procedures that manipulate Master_Ids because
258
   --  a Master_Id must be generated for access to limited class-wide types,
259
   --  whose root may be extended with task components.
260
 
261
   function Current_Master_NT return Integer;
262
   procedure Enter_Master_NT;
263
   procedure Complete_Master_NT;
264
 
265
   Current_Master  : Get_Integer_Call :=  Current_Master_NT'Access;
266
   Enter_Master    : No_Param_Proc    :=  Enter_Master_NT'Access;
267
   Complete_Master : No_Param_Proc    :=  Complete_Master_NT'Access;
268
 
269
   ----------------------
270
   -- Delay Soft-Links --
271
   ----------------------
272
 
273
   --  Soft-Links are used for procedures that manipulate time to avoid
274
   --  dragging the tasking run time when using delay statements.
275
 
276
   Timed_Delay : Timed_Delay_Call;
277
 
278
   --------------------------
279
   -- Task Name Soft-Links --
280
   --------------------------
281
 
282
   function Task_Name_NT return String;
283
 
284
   Task_Name : Task_Name_Call := Task_Name_NT'Access;
285
 
286
   -------------------------------------
287
   -- Exception Tracebacks Soft-Links --
288
   -------------------------------------
289
 
290
   Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
291
   --  Wrapper to the possible user specified traceback decorator to be
292
   --  called during automatic output of exception data.
293
 
294
   --  The nullity of this wrapper shall correspond to the nullity of the
295
   --  current actual decorator. This is ensured first by the null initial
296
   --  value of the corresponding variables, and then by Set_Trace_Decorator
297
   --  in g-exctra.adb.
298
 
299
   pragma Atomic (Traceback_Decorator_Wrapper);
300
   --  Since concurrent read/write operations may occur on this variable.
301
   --  See the body of Tailored_Exception_Traceback in Ada.Exceptions for
302
   --  a more detailed description of the potential problems.
303
 
304
   ------------------------
305
   -- Task Specific Data --
306
   ------------------------
307
 
308
   --  Here we define a single type that encapsulates the various task
309
   --  specific data. This type is used to store the necessary data into the
310
   --  Task_Control_Block or into a global variable in the non tasking case.
311
 
312
   type TSD is record
313
      Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
314
      --  Information on stack (Base/Limit/Size) used by System.Stack_Checking.
315
      --  If this TSD does not belong to the environment task, the Size field
316
      --  must be initialized to the tasks requested stack size before the task
317
      --  can do its first stack check.
318
 
319
      pragma Warnings (Off);
320
      --  Needed because we are giving a non-static default to an object in
321
      --  a preelaborated unit, which is formally not permitted, but OK here.
322
 
323
      Jmpbuf_Address : System.Address := System.Null_Address;
324
      --  Address of jump buffer used to store the address of the current
325
      --  longjmp/setjmp buffer for exception management. These buffers are
326
      --  threaded into a stack, and the address here is the top of the stack.
327
      --  A null address means that no exception handler is currently active.
328
 
329
      Sec_Stack_Addr : System.Address := System.Null_Address;
330
      pragma Warnings (On);
331
      --  Address of currently allocated secondary stack
332
 
333
      Current_Excep : aliased EO;
334
      --  Exception occurrence that contains the information for the current
335
      --  exception. Note that any exception in the same task destroys this
336
      --  information, so the data in this variable must be copied out before
337
      --  another exception can occur.
338
      --
339
      --  Also act as a list of the active exceptions in the case of the GCC
340
      --  exception mechanism, organized as a stack with the most recent first.
341
   end record;
342
 
343
   procedure Create_TSD (New_TSD : in out TSD);
344
   pragma Inline (Create_TSD);
345
   --  Called from s-tassta when a new thread is created to perform
346
   --  any required initialization of the TSD.
347
 
348
   procedure Destroy_TSD (Old_TSD : in out TSD);
349
   pragma Inline (Destroy_TSD);
350
   --  Called from s-tassta just before a thread is destroyed to perform
351
   --  any required finalization.
352
 
353
   function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
354
   pragma Inline (Get_GNAT_Exception);
355
   --  This function obtains the Exception_Id from the Exception_Occurrence
356
   --  referenced by the Current_Excep field of the task specific data, i.e.
357
   --  the call is equivalent to
358
   --  Exception_Identity (Get_Current_Exception.all)
359
 
360
   --  Export the Get/Set routines for the various Task Specific Data (TSD)
361
   --  elements as callable subprograms instead of objects of access to
362
   --  subprogram types.
363
 
364
   function  Get_Jmpbuf_Address_Soft return  Address;
365
   procedure Set_Jmpbuf_Address_Soft (Addr : Address);
366
   pragma Inline (Get_Jmpbuf_Address_Soft);
367
   pragma Inline (Set_Jmpbuf_Address_Soft);
368
 
369
   function  Get_Sec_Stack_Addr_Soft return  Address;
370
   procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
371
   pragma Inline (Get_Sec_Stack_Addr_Soft);
372
   pragma Inline (Set_Sec_Stack_Addr_Soft);
373
 
374
   function Get_Exc_Stack_Addr_Soft return Address;
375
 
376
   --  The following is a dummy record designed to mimic Communication_Block as
377
   --  defined in s-tpobop.ads:
378
 
379
   --     type Communication_Block is record
380
   --        Self      : Task_Id;  --  An access type
381
   --        Enqueued  : Boolean := True;
382
   --        Cancelled : Boolean := False;
383
   --     end record;
384
 
385
   --  The record is used in the construction of the predefined dispatching
386
   --  primitive _disp_asynchronous_select in order to avoid the import of
387
   --  System.Tasking.Protected_Objects.Operations. Note that this package
388
   --  is always imported in the presence of interfaces since the dispatch
389
   --  table uses entities from here.
390
 
391
   type Dummy_Communication_Block is record
392
      Comp_1 : Address;  --  Address and access have the same size
393
      Comp_2 : Boolean;
394
      Comp_3 : Boolean;
395
   end record;
396
 
397
end System.Soft_Links;

powered by: WebSVN 2.1.0

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