1------------------------------------------------------------------------------ 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-2013, 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 32pragma 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 36pragma 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 41with Ada.Exceptions; 42with Ada.Exceptions.Is_Null_Occurrence; 43 44with System.Task_Primitives.Operations; 45with System.Tasking; 46with System.Stack_Checking; 47 48package 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 all other tasks is handled in the Task_Wrapper. 155 156 -- We do not want to enable this check and e.g. call System.OS_Lib.Abort 157 -- here because some restricted run-times may not have System.OS_Lib 158 -- (e.g. JVM), and calling abort may do more harm than good to the 159 -- main application. 160 161 pragma Assert (Self_Id = STPO.Environment_Task); 162 163 -- Normal task termination 164 165 if Is_Null_Occurrence (Excep) then 166 Cause := System.Tasking.Normal; 167 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 168 169 -- Abnormal task termination 170 171 elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then 172 Cause := System.Tasking.Abnormal; 173 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 174 175 -- Termination because of an unhandled exception 176 177 else 178 Cause := System.Tasking.Unhandled_Exception; 179 Ada.Exceptions.Save_Occurrence (EO, Excep); 180 end if; 181 182 -- There is no need for explicit protection against race conditions for 183 -- this part because it can only be executed by the environment task 184 -- after all the other tasks have been finalized. Note that there is no 185 -- fall-back handler which could apply to this environment task because 186 -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the 187 -- fall-back handler applies only to the dependent tasks of the task". 188 189 if Self_Id.Common.Specific_Handler /= null then 190 Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); 191 end if; 192 end Task_Termination_Handler_T; 193 194 ----------------------------- 195 -- Init_Tasking_Soft_Links -- 196 ----------------------------- 197 198 procedure Init_Tasking_Soft_Links is 199 begin 200 -- Set links only if not set already 201 202 if not Initialized then 203 204 -- Mark tasking soft links as initialized 205 206 Initialized := True; 207 208 -- The application being executed uses tasking so that the tasking 209 -- version of the following soft links need to be used. 210 211 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; 212 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; 213 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; 214 SSL.Get_Stack_Info := Get_Stack_Info'Access; 215 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; 216 SSL.Timed_Delay := Timed_Delay_T'Access; 217 SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; 218 219 -- No need to create a new secondary stack, since we will use the 220 -- default one created in s-secsta.adb. 221 222 SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); 223 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); 224 end if; 225 end Init_Tasking_Soft_Links; 226 227end System.Soft_Links.Tasking; 228