File : s-taprop-pikeos.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                     Copyright (C) 2001-2016, AdaCore                     --
  10 --                                                                          --
  11 -- GNARL 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. GNARL 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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 ------------------------------------------------------------------------------
  28 
  29 --  This is the pikeos version of this package
  30 
  31 --  This package contains all the GNULL primitives that interface directly with
  32 --  the underlying kernel.
  33 
  34 pragma Restrictions (No_Elaboration_Code);
  35 
  36 with Ada.Unchecked_Conversion;
  37 
  38 with System.Storage_Elements;
  39 with System.Tasking.Debug;
  40 
  41 package body System.Task_Primitives.Operations is
  42 
  43    use System.OS_Interface;
  44    use System.Parameters;
  45    use System.Storage_Elements;
  46 
  47    use type System.Tasking.Task_Id;
  48 
  49    ---------------------
  50    -- Local Functions --
  51    ---------------------
  52 
  53    function To_Address is new
  54      Ada.Unchecked_Conversion (ST.Task_Id, System.Address);
  55 
  56    function To_Task_Id is new
  57      Ada.Unchecked_Conversion (System.Address, ST.Task_Id);
  58 
  59    ----------
  60    -- Self --
  61    ----------
  62 
  63    function Self return ST.Task_Id is
  64    begin
  65       return To_Task_Id (System.OS_Interface.Get_ATCB);
  66    end Self;
  67 
  68    -----------
  69    -- Sleep --
  70    -----------
  71 
  72    procedure Sleep
  73      (Self_ID : ST.Task_Id;
  74       Reason  : System.Tasking.Task_States)
  75    is
  76       pragma Unreferenced (Reason);
  77    begin
  78       --  A task can only suspend itself
  79 
  80       pragma Assert (Self_ID = Self);
  81 
  82       System.OS_Interface.Sleep;
  83    end Sleep;
  84 
  85    -----------------
  86    -- Delay_Until --
  87    -----------------
  88 
  89    procedure Delay_Until (Abs_Time : Time) is
  90       Self_ID : constant ST.Task_Id := Self;
  91    begin
  92       Self_ID.Common.State := ST.Delay_Sleep;
  93       System.OS_Interface.Delay_Until (System.OS_Interface.Time (Abs_Time));
  94       Self_ID.Common.State := ST.Runnable;
  95    end Delay_Until;
  96 
  97    ---------------------
  98    -- Monotonic_Clock --
  99    ---------------------
 100 
 101    function Monotonic_Clock return Time is
 102    begin
 103       return Time (System.OS_Interface.Clock);
 104    end Monotonic_Clock;
 105 
 106    ------------
 107    -- Wakeup --
 108    ------------
 109 
 110    procedure Wakeup (T : ST.Task_Id; Reason : System.Tasking.Task_States) is
 111       pragma Unreferenced (Reason);
 112    begin
 113       System.OS_Interface.Wakeup (T.Common.LL.Thread);
 114    end Wakeup;
 115 
 116    ------------------
 117    -- Set_Priority --
 118    ------------------
 119 
 120    procedure Set_Priority (T : ST.Task_Id; Prio : ST.Extended_Priority) is
 121    begin
 122       --  A task can only change its own priority
 123 
 124       pragma Assert (T = Self);
 125 
 126       --  Change the priority in the underlying executive
 127 
 128       System.OS_Interface.Set_Priority (Prio);
 129    end Set_Priority;
 130 
 131    ------------------
 132    -- Get_Priority --
 133    ------------------
 134 
 135    function Get_Priority (T : ST.Task_Id) return ST.Extended_Priority is
 136    begin
 137       --  Get current active priority
 138 
 139       return System.OS_Interface.Get_Priority (T.Common.LL.Thread);
 140    end Get_Priority;
 141 
 142    ------------------
 143    -- Get_Affinity --
 144    ------------------
 145 
 146    function Get_Affinity
 147      (T : ST.Task_Id) return System.Multiprocessors.CPU_Range
 148    is
 149    begin
 150       return System.OS_Interface.Get_Affinity (T.Common.LL.Thread);
 151    end Get_Affinity;
 152 
 153    -------------
 154    -- Get_CPU --
 155    -------------
 156 
 157    function Get_CPU (T : ST.Task_Id) return System.Multiprocessors.CPU is
 158    begin
 159 
 160       return System.OS_Interface.Get_CPU (T.Common.LL.Thread);
 161    end Get_CPU;
 162 
 163    -------------------
 164    -- Get_Thread_Id --
 165    -------------------
 166 
 167    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 168    begin
 169       return T.Common.LL.Thread;
 170    end Get_Thread_Id;
 171 
 172    ----------------
 173    -- Enter_Task --
 174    ----------------
 175 
 176    procedure Enter_Task (Self_ID : ST.Task_Id) is
 177    begin
 178       --  Notify the underlying executive about the Ada task that is being
 179       --  executed by the running thread.
 180 
 181       System.OS_Interface.Set_ATCB (To_Address (Self_ID));
 182 
 183       --  Set lwp (for gdb)
 184 
 185       Self_ID.Common.LL.Lwp := Lwp_Self;
 186 
 187       --  Register the task to System.Tasking.Debug
 188 
 189       System.Tasking.Debug.Add_Task_Id (Self_ID);
 190 
 191       --  Ensure that the task has the right priority priority at the end
 192       --  of its initialization (before calling the task's code).
 193 
 194       System.OS_Interface.Set_Priority (Self_ID.Common.Base_Priority);
 195    end Enter_Task;
 196 
 197    --------------------
 198    -- Initialize_TCB --
 199    --------------------
 200 
 201    procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean) is
 202       pragma Unreferenced (Self_ID);
 203    begin
 204       --  Nothing to be done as part of the initialization of TCBs
 205 
 206       Succeeded := True;
 207    end Initialize_TCB;
 208 
 209    -----------------
 210    -- Create_Task --
 211    -----------------
 212 
 213    procedure Create_Task
 214      (T          : ST.Task_Id;
 215       Wrapper    : System.Address;
 216       Stack_Size : System.Parameters.Size_Type;
 217       Priority   : ST.Extended_Priority;
 218       Base_CPU   : System.Multiprocessors.CPU_Range;
 219       Succeeded  : out Boolean)
 220    is
 221    begin
 222       --  The stack has been preallocated for these targets
 223 
 224       pragma Assert
 225         (T.Common.Compiler_Data.Pri_Stack_Info.Start_Address /= Null_Address
 226          and then Storage_Offset (Stack_Size) =
 227            T.Common.Compiler_Data.Pri_Stack_Info.Size);
 228 
 229       T.Common.LL.Thread := T.Common.LL.Thread_Desc'Access;
 230 
 231       --  Create the underlying task
 232 
 233       System.OS_Interface.Thread_Create
 234         (T.Common.LL.Thread,
 235          Wrapper,
 236          To_Address (T),
 237          Priority,
 238          Base_CPU,
 239          T.Common.Compiler_Data.Pri_Stack_Info.Start_Address,
 240          Size_Type (T.Common.Compiler_Data.Pri_Stack_Info.Size));
 241 
 242       Succeeded := True;
 243    end Create_Task;
 244 
 245    ----------------
 246    -- Initialize --
 247    ----------------
 248 
 249    procedure Initialize (Environment_Task : ST.Task_Id) is
 250    begin
 251       Environment_Task.Common.LL.Thread :=
 252         Environment_Task.Common.LL.Thread_Desc'Access;
 253 
 254       --  Clear Activation_Link, as required by Add_Task_Id
 255 
 256       Environment_Task.Common.Activation_Link := null;
 257 
 258       --  First the underlying multitasking executive must be initialized
 259 
 260       System.OS_Interface.Initialize
 261         (Environment_Task.Common.LL.Thread,
 262          Environment_Task.Common.Base_Priority);
 263 
 264       --  The environment task must also execute its initialization
 265 
 266       Enter_Task (Environment_Task);
 267 
 268       --  Store the identifier for the environment task
 269 
 270       Operations.Environment_Task := Environment_Task;
 271    end Initialize;
 272 
 273    ---------------------
 274    -- Is_Task_Context --
 275    ---------------------
 276 
 277    function Is_Task_Context return Boolean is
 278    begin
 279       return System.OS_Interface.Current_Interrupt = No_Interrupt;
 280    end Is_Task_Context;
 281 
 282 end System.Task_Primitives.Operations;