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-2019, 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; 47with System.Secondary_Stack; 48 49package body System.Soft_Links.Tasking is 50 51 package STPO renames System.Task_Primitives.Operations; 52 package SSL renames System.Soft_Links; 53 54 use Ada.Exceptions; 55 56 use type System.Secondary_Stack.SS_Stack_Ptr; 57 58 use type System.Tasking.Task_Id; 59 use type System.Tasking.Termination_Handler; 60 61 ---------------- 62 -- Local Data -- 63 ---------------- 64 65 Initialized : Boolean := False; 66 -- Boolean flag that indicates whether the tasking soft links have 67 -- already been set. 68 69 ----------------------------------------------------------------- 70 -- Tasking Versions of Services Needed by Non-Tasking Programs -- 71 ----------------------------------------------------------------- 72 73 function Get_Jmpbuf_Address return Address; 74 procedure Set_Jmpbuf_Address (Addr : Address); 75 -- Get/Set Jmpbuf_Address for current task 76 77 function Get_Sec_Stack return SST.SS_Stack_Ptr; 78 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); 79 -- Get/Set location of current task's secondary stack 80 81 procedure Timed_Delay_T (Time : Duration; Mode : Integer); 82 -- Task-safe version of SSL.Timed_Delay 83 84 procedure Task_Termination_Handler_T (Excep : SSL.EO); 85 -- Task-safe version of the task termination procedure 86 87 function Get_Stack_Info return Stack_Checking.Stack_Access; 88 -- Get access to the current task's Stack_Info 89 90 -------------------------- 91 -- Soft-Link Get Bodies -- 92 -------------------------- 93 94 function Get_Jmpbuf_Address return Address is 95 begin 96 return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; 97 end Get_Jmpbuf_Address; 98 99 function Get_Sec_Stack return SST.SS_Stack_Ptr is 100 begin 101 return Result : constant SST.SS_Stack_Ptr := 102 STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr 103 do 104 pragma Assert (Result /= null); 105 end return; 106 end Get_Sec_Stack; 107 108 function Get_Stack_Info return Stack_Checking.Stack_Access is 109 begin 110 return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; 111 end Get_Stack_Info; 112 113 -------------------------- 114 -- Soft-Link Set Bodies -- 115 -------------------------- 116 117 procedure Set_Jmpbuf_Address (Addr : Address) is 118 begin 119 STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; 120 end Set_Jmpbuf_Address; 121 122 procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is 123 begin 124 STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr := Stack; 125 end Set_Sec_Stack; 126 127 ------------------- 128 -- Timed_Delay_T -- 129 ------------------- 130 131 procedure Timed_Delay_T (Time : Duration; Mode : Integer) is 132 Self_Id : constant System.Tasking.Task_Id := STPO.Self; 133 134 begin 135 -- In case pragma Detect_Blocking is active then Program_Error 136 -- must be raised if this potentially blocking operation 137 -- is called from a protected operation. 138 139 if System.Tasking.Detect_Blocking 140 and then Self_Id.Common.Protected_Action_Nesting > 0 141 then 142 raise Program_Error with "potentially blocking operation"; 143 else 144 Abort_Defer.all; 145 STPO.Timed_Delay (Self_Id, Time, Mode); 146 Abort_Undefer.all; 147 end if; 148 end Timed_Delay_T; 149 150 -------------------------------- 151 -- Task_Termination_Handler_T -- 152 -------------------------------- 153 154 procedure Task_Termination_Handler_T (Excep : SSL.EO) is 155 Self_Id : constant System.Tasking.Task_Id := STPO.Self; 156 Cause : System.Tasking.Cause_Of_Termination; 157 EO : Ada.Exceptions.Exception_Occurrence; 158 159 begin 160 -- We can only be here because we are terminating the environment task. 161 -- Task termination for all other tasks is handled in the Task_Wrapper. 162 163 -- We do not want to enable this check and e.g. call System.OS_Lib.Abort 164 -- here because some restricted run-times may not have System.OS_Lib 165 -- and calling abort may do more harm than good to the main application. 166 167 pragma Assert (Self_Id = STPO.Environment_Task); 168 169 -- Normal task termination 170 171 if Is_Null_Occurrence (Excep) then 172 Cause := System.Tasking.Normal; 173 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 174 175 -- Abnormal task termination 176 177 elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then 178 Cause := System.Tasking.Abnormal; 179 Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 180 181 -- Termination because of an unhandled exception 182 183 else 184 Cause := System.Tasking.Unhandled_Exception; 185 Ada.Exceptions.Save_Occurrence (EO, Excep); 186 end if; 187 188 -- There is no need for explicit protection against race conditions for 189 -- this part because it can only be executed by the environment task 190 -- after all the other tasks have been finalized. Note that there is no 191 -- fall-back handler which could apply to this environment task because 192 -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the 193 -- fall-back handler applies only to the dependent tasks of the task". 194 195 if Self_Id.Common.Specific_Handler /= null then 196 Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); 197 end if; 198 end Task_Termination_Handler_T; 199 200 ----------------------------- 201 -- Init_Tasking_Soft_Links -- 202 ----------------------------- 203 204 procedure Init_Tasking_Soft_Links is 205 begin 206 -- Set links only if not set already 207 208 if not Initialized then 209 210 -- Mark tasking soft links as initialized 211 212 Initialized := True; 213 214 -- The application being executed uses tasking so that the tasking 215 -- version of the following soft links need to be used. 216 217 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; 218 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; 219 SSL.Get_Sec_Stack := Get_Sec_Stack'Access; 220 SSL.Get_Stack_Info := Get_Stack_Info'Access; 221 SSL.Set_Sec_Stack := Set_Sec_Stack'Access; 222 SSL.Timed_Delay := Timed_Delay_T'Access; 223 SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; 224 225 -- No need to create a new secondary stack, since we will use the 226 -- default one created in s-secsta.adb. 227 228 SSL.Set_Sec_Stack (SSL.Get_Sec_Stack_NT); 229 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); 230 end if; 231 232 pragma Assert (Get_Sec_Stack /= null); 233 end Init_Tasking_Soft_Links; 234 235end System.Soft_Links.Tasking; 236