1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . T H R E A D S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2010, AdaCore -- 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 32with Ada.Task_Identification; use Ada.Task_Identification; 33with System.Task_Primitives.Operations; 34with System.Tasking; 35with System.Tasking.Stages; use System.Tasking.Stages; 36with System.OS_Interface; use System.OS_Interface; 37with System.Soft_Links; use System.Soft_Links; 38with Ada.Unchecked_Conversion; 39 40package body GNAT.Threads is 41 42 use System; 43 44 package STPO renames System.Task_Primitives.Operations; 45 46 type Thread_Id_Ptr is access all Thread_Id; 47 48 pragma Warnings (Off); 49 -- The following unchecked conversions are aliasing safe, since they 50 -- are never used to create pointers to improperly aliased data. 51 52 function To_Addr is new Ada.Unchecked_Conversion (Task_Id, Address); 53 function To_Id is new Ada.Unchecked_Conversion (Address, Task_Id); 54 function To_Id is new Ada.Unchecked_Conversion (Address, Tasking.Task_Id); 55 function To_Tid is new Ada.Unchecked_Conversion 56 (Address, Ada.Task_Identification.Task_Id); 57 function To_Thread is new Ada.Unchecked_Conversion (Address, Thread_Id_Ptr); 58 59 pragma Warnings (On); 60 61 type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr); 62 63 task type Thread 64 (Stsz : Natural; 65 Prio : Any_Priority; 66 Parm : Void_Ptr; 67 Code : Code_Proc) 68 is 69 pragma Priority (Prio); 70 pragma Storage_Size (Stsz); 71 end Thread; 72 73 task body Thread is 74 begin 75 Code.all (To_Addr (Current_Task), Parm); 76 end Thread; 77 78 type Tptr is access Thread; 79 80 ------------------- 81 -- Create_Thread -- 82 ------------------- 83 84 function Create_Thread 85 (Code : Address; 86 Parm : Void_Ptr; 87 Size : Natural; 88 Prio : Integer) return System.Address 89 is 90 TP : Tptr; 91 92 function To_CP is new Ada.Unchecked_Conversion (Address, Code_Proc); 93 94 begin 95 TP := new Thread (Size, Prio, Parm, To_CP (Code)); 96 return To_Addr (TP'Identity); 97 end Create_Thread; 98 99 --------------------- 100 -- Register_Thread -- 101 --------------------- 102 103 function Register_Thread return System.Address is 104 begin 105 return Task_Primitives.Operations.Register_Foreign_Thread.all'Address; 106 end Register_Thread; 107 108 ----------------------- 109 -- Unregister_Thread -- 110 ----------------------- 111 112 procedure Unregister_Thread is 113 Self_Id : constant Tasking.Task_Id := Task_Primitives.Operations.Self; 114 begin 115 Self_Id.Common.State := Tasking.Terminated; 116 Destroy_TSD (Self_Id.Common.Compiler_Data); 117 Free_Task (Self_Id); 118 end Unregister_Thread; 119 120 -------------------------- 121 -- Unregister_Thread_Id -- 122 -------------------------- 123 124 procedure Unregister_Thread_Id (Thread : System.Address) is 125 Thr : constant Thread_Id := To_Thread (Thread).all; 126 T : Tasking.Task_Id; 127 128 use type Tasking.Task_Id; 129 -- This use clause should be removed once a visibility problem 130 -- with the MaRTE run time has been fixed. ??? 131 132 pragma Warnings (Off); 133 use type System.OS_Interface.Thread_Id; 134 pragma Warnings (On); 135 136 begin 137 STPO.Lock_RTS; 138 139 T := Tasking.All_Tasks_List; 140 loop 141 exit when T = null or else STPO.Get_Thread_Id (T) = Thr; 142 143 T := T.Common.All_Tasks_Link; 144 end loop; 145 146 STPO.Unlock_RTS; 147 148 if T /= null then 149 T.Common.State := Tasking.Terminated; 150 Destroy_TSD (T.Common.Compiler_Data); 151 Free_Task (T); 152 end if; 153 end Unregister_Thread_Id; 154 155 -------------------- 156 -- Destroy_Thread -- 157 -------------------- 158 159 procedure Destroy_Thread (Id : Address) is 160 Tid : constant Task_Id := To_Id (Id); 161 begin 162 Abort_Task (Tid); 163 end Destroy_Thread; 164 165 ---------------- 166 -- Get_Thread -- 167 ---------------- 168 169 procedure Get_Thread (Id : Address; Thread : Address) is 170 Thr : constant Thread_Id_Ptr := To_Thread (Thread); 171 begin 172 Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); 173 end Get_Thread; 174 175 ---------------- 176 -- To_Task_Id -- 177 ---------------- 178 179 function To_Task_Id 180 (Id : System.Address) return Ada.Task_Identification.Task_Id 181 is 182 begin 183 return To_Tid (Id); 184 end To_Task_Id; 185 186end GNAT.Threads; 187