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-2015, 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 Result : constant Address := 99 STPO.Self.Common.Compiler_Data.Sec_Stack_Addr 100 do 101 pragma Assert (Result /= Null_Address); 102 end return; 103 end Get_Sec_Stack_Addr; 104 105 function Get_Stack_Info return Stack_Checking.Stack_Access is 106 begin 107 return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; 108 end Get_Stack_Info; 109 110 -------------------------- 111 -- Soft-Link Set Bodies -- 112 -------------------------- 113 114 procedure Set_Jmpbuf_Address (Addr : Address) is 115 begin 116 STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; 117 end Set_Jmpbuf_Address; 118 119 procedure Set_Sec_Stack_Addr (Addr : Address) is 120 begin 121 STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; 122 end Set_Sec_Stack_Addr; 123 124 ------------------- 125 -- Timed_Delay_T -- 126 ------------------- 127 128 procedure Timed_Delay_T (Time : Duration; Mode : Integer) is 129 Self_Id : constant System.Tasking.Task_Id := STPO.Self; 130 131 begin 132 -- In case pragma Detect_Blocking is active then Program_Error 133 -- must be raised if this potentially blocking operation 134 -- is called from a protected operation. 135 136 if System.Tasking.Detect_Blocking 137 and then Self_Id.Common.Protected_Action_Nesting > 0 138 then 139 raise Program_Error with "potentially blocking operation"; 140 else 141 Abort_Defer.all; 142 STPO.Timed_Delay (Self_Id, Time, Mode); 143 Abort_Undefer.all; 144 end if; 145 end Timed_Delay_T; 146 147 -------------------------------- 148 -- Task_Termination_Handler_T -- 149 -------------------------------- 150 151 procedure Task_Termination_Handler_T (Excep : SSL.EO) is 152 Self_Id : constant System.Tasking.Task_Id := STPO.Self; 153 Cause : System.Tasking.Cause_Of_Termination; 154 EO : Ada.Exceptions.Exception_Occurrence; 155 156 begin 157 -- We can only be here because we are terminating the environment task. 158 -- Task termination for all other tasks is handled in the Task_Wrapper. 159 160 -- We do not want to enable this check and e.g. call System.OS_Lib.Abort 161 -- here because some restricted run-times may not have System.OS_Lib 162 -- and calling abort may do more harm than good to the main application. 163 164 pragma Assert (Self_Id = STPO.Environment_Task); 165 166 -- Normal task termination 167 168 if Is_Null_Occurrence (Excep) then 169 Cause := System.Tasking.Normal; 170 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 171 172 -- Abnormal task termination 173 174 elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then 175 Cause := System.Tasking.Abnormal; 176 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 177 178 -- Termination because of an unhandled exception 179 180 else 181 Cause := System.Tasking.Unhandled_Exception; 182 Ada.Exceptions.Save_Occurrence (EO, Excep); 183 end if; 184 185 -- There is no need for explicit protection against race conditions for 186 -- this part because it can only be executed by the environment task 187 -- after all the other tasks have been finalized. Note that there is no 188 -- fall-back handler which could apply to this environment task because 189 -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the 190 -- fall-back handler applies only to the dependent tasks of the task". 191 192 if Self_Id.Common.Specific_Handler /= null then 193 Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); 194 end if; 195 end Task_Termination_Handler_T; 196 197 ----------------------------- 198 -- Init_Tasking_Soft_Links -- 199 ----------------------------- 200 201 procedure Init_Tasking_Soft_Links is 202 begin 203 -- Set links only if not set already 204 205 if not Initialized then 206 207 -- Mark tasking soft links as initialized 208 209 Initialized := True; 210 211 -- The application being executed uses tasking so that the tasking 212 -- version of the following soft links need to be used. 213 214 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; 215 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; 216 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; 217 SSL.Get_Stack_Info := Get_Stack_Info'Access; 218 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; 219 SSL.Timed_Delay := Timed_Delay_T'Access; 220 SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; 221 222 -- No need to create a new secondary stack, since we will use the 223 -- default one created in s-secsta.adb. 224 225 SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); 226 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); 227 end if; 228 229 pragma Assert (Get_Sec_Stack_Addr /= Null_Address); 230 end Init_Tasking_Soft_Links; 231 232end System.Soft_Links.Tasking; 233