OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-solita.adb] - 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 . T A S K I N G            --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-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
pragma Style_Checks (All_Checks);
33
--  Turn off subprogram alpha ordering check, since we group soft link bodies
34
--  and dummy soft link bodies together separately in this unit.
35
 
36
pragma Polling (Off);
37
--  Turn polling off for this package. We don't need polling during any of the
38
--  routines in this package, and more to the point, if we try to poll it can
39
--  cause infinite loops.
40
 
41
with Ada.Exceptions;
42
with Ada.Exceptions.Is_Null_Occurrence;
43
 
44
with System.Task_Primitives.Operations;
45
with System.Tasking;
46
with System.Stack_Checking;
47
 
48
package body System.Soft_Links.Tasking is
49
 
50
   package STPO renames System.Task_Primitives.Operations;
51
   package SSL  renames System.Soft_Links;
52
 
53
   use Ada.Exceptions;
54
 
55
   use type System.Tasking.Task_Id;
56
   use type System.Tasking.Termination_Handler;
57
 
58
   ----------------
59
   -- Local Data --
60
   ----------------
61
 
62
   Initialized : Boolean := False;
63
   --  Boolean flag that indicates whether the tasking soft links have
64
   --  already been set.
65
 
66
   -----------------------------------------------------------------
67
   -- Tasking Versions of Services Needed by Non-Tasking Programs --
68
   -----------------------------------------------------------------
69
 
70
   function  Get_Jmpbuf_Address return  Address;
71
   procedure Set_Jmpbuf_Address (Addr : Address);
72
   --  Get/Set Jmpbuf_Address for current task
73
 
74
   function  Get_Sec_Stack_Addr return  Address;
75
   procedure Set_Sec_Stack_Addr (Addr : Address);
76
   --  Get/Set location of current task's secondary stack
77
 
78
   procedure Timed_Delay_T (Time : Duration; Mode : Integer);
79
   --  Task-safe version of SSL.Timed_Delay
80
 
81
   procedure Task_Termination_Handler_T  (Excep : SSL.EO);
82
   --  Task-safe version of the task termination procedure
83
 
84
   function Get_Stack_Info return Stack_Checking.Stack_Access;
85
   --  Get access to the current task's Stack_Info
86
 
87
   --------------------------
88
   -- Soft-Link Get Bodies --
89
   --------------------------
90
 
91
   function Get_Jmpbuf_Address return  Address is
92
   begin
93
      return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
94
   end Get_Jmpbuf_Address;
95
 
96
   function Get_Sec_Stack_Addr return  Address is
97
   begin
98
      return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
99
   end Get_Sec_Stack_Addr;
100
 
101
   function Get_Stack_Info return Stack_Checking.Stack_Access is
102
   begin
103
      return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
104
   end Get_Stack_Info;
105
 
106
   --------------------------
107
   -- Soft-Link Set Bodies --
108
   --------------------------
109
 
110
   procedure Set_Jmpbuf_Address (Addr : Address) is
111
   begin
112
      STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
113
   end Set_Jmpbuf_Address;
114
 
115
   procedure Set_Sec_Stack_Addr (Addr : Address) is
116
   begin
117
      STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
118
   end Set_Sec_Stack_Addr;
119
 
120
   -------------------
121
   -- Timed_Delay_T --
122
   -------------------
123
 
124
   procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
125
      Self_Id : constant System.Tasking.Task_Id := STPO.Self;
126
 
127
   begin
128
      --  In case pragma Detect_Blocking is active then Program_Error
129
      --  must be raised if this potentially blocking operation
130
      --  is called from a protected operation.
131
 
132
      if System.Tasking.Detect_Blocking
133
        and then Self_Id.Common.Protected_Action_Nesting > 0
134
      then
135
         raise Program_Error with "potentially blocking operation";
136
      else
137
         Abort_Defer.all;
138
         STPO.Timed_Delay (Self_Id, Time, Mode);
139
         Abort_Undefer.all;
140
      end if;
141
   end Timed_Delay_T;
142
 
143
   --------------------------------
144
   -- Task_Termination_Handler_T --
145
   --------------------------------
146
 
147
   procedure Task_Termination_Handler_T (Excep : SSL.EO) is
148
      Self_Id : constant System.Tasking.Task_Id := STPO.Self;
149
      Cause   : System.Tasking.Cause_Of_Termination;
150
      EO      : Ada.Exceptions.Exception_Occurrence;
151
 
152
   begin
153
      --  We can only be here because we are terminating the environment task.
154
      --  Task termination for the rest of the tasks is handled in the
155
      --  Task_Wrapper.
156
 
157
      pragma Assert (Self_Id = STPO.Environment_Task);
158
 
159
      --  Normal task termination
160
 
161
      if Is_Null_Occurrence (Excep) then
162
         Cause := System.Tasking.Normal;
163
         Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
164
 
165
      --  Abnormal task termination
166
 
167
      elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
168
         Cause := System.Tasking.Abnormal;
169
         Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
170
 
171
      --  Termination because of an unhandled exception
172
 
173
      else
174
         Cause := System.Tasking.Unhandled_Exception;
175
         Ada.Exceptions.Save_Occurrence (EO, Excep);
176
      end if;
177
 
178
      --  There is no need for explicit protection against race conditions
179
      --  for this part because it can only be executed by the environment
180
      --  task after all the other tasks have been finalized.
181
 
182
      if Self_Id.Common.Specific_Handler /= null then
183
         Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
184
      elsif Self_Id.Common.Fall_Back_Handler /= null then
185
         Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO);
186
      end if;
187
   end Task_Termination_Handler_T;
188
 
189
   -----------------------------
190
   -- Init_Tasking_Soft_Links --
191
   -----------------------------
192
 
193
   procedure Init_Tasking_Soft_Links is
194
   begin
195
      --  Set links only if not set already
196
 
197
      if not Initialized then
198
 
199
         --  Mark tasking soft links as initialized
200
 
201
         Initialized := True;
202
 
203
         --  The application being executed uses tasking so that the tasking
204
         --  version of the following soft links need to be used.
205
 
206
         SSL.Get_Jmpbuf_Address       := Get_Jmpbuf_Address'Access;
207
         SSL.Set_Jmpbuf_Address       := Set_Jmpbuf_Address'Access;
208
         SSL.Get_Sec_Stack_Addr       := Get_Sec_Stack_Addr'Access;
209
         SSL.Get_Stack_Info           := Get_Stack_Info'Access;
210
         SSL.Set_Sec_Stack_Addr       := Set_Sec_Stack_Addr'Access;
211
         SSL.Timed_Delay              := Timed_Delay_T'Access;
212
         SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
213
 
214
         --  No need to create a new Secondary Stack, since we will use the
215
         --  default one created in s-secsta.adb
216
 
217
         SSL.Set_Sec_Stack_Addr     (SSL.Get_Sec_Stack_Addr_NT);
218
         SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
219
      end if;
220
   end Init_Tasking_Soft_Links;
221
 
222
end System.Soft_Links.Tasking;

powered by: WebSVN 2.1.0

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