gnat_arm_elf_13.2.1_db1e9283/arm-eabi/lib/gnat/embedded-stm32f4/gnarl/s-bbthre.adb

------------------------------------------------------------------------------
--                                                                          --
--                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
--                                                                          --
--                       S Y S T E M . B B . T H R E A D S                  --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--        Copyright (C) 1999-2002 Universidad Politecnica de Madrid         --
--             Copyright (C) 2003-2005 The European Space Agency            --
--                     Copyright (C) 2003-2023, AdaCore                     --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
-- The port of GNARL to bare board targets was initially developed by the   --
-- Real-Time Systems Group at the Technical University of Madrid.           --
--                                                                          --
------------------------------------------------------------------------------

pragma Restrictions (No_Elaboration_Code);

with System.Parameters;
with System.BB.Interrupts;
with System.BB.Protection;
with System.BB.Threads.Queues;

package body System.BB.Threads is

   use System.Multiprocessors;
   use System.BB.CPU_Primitives;
   use System.BB.Board_Support.Multiprocessors;
   use System.BB.Time;
   use Board_Support;

   use type System.Storage_Elements.Storage_Offset;

   procedure Initialize_Thread
     (Id            : Thread_Id;
      Code          : System.Address;
      Arg           : System.Address;
      Priority      : Integer;
      This_CPU      : System.Multiprocessors.CPU_Range;
      Stack_Top     : System.Address;
      Stack_Bottom  : System.Address);
   --  Intialize the thread's kernel data structure and its context

   -----------------------
   -- Stack information --
   -----------------------

   --  Boundaries of the stack for the environment task, defined by the linker
   --  script file.

   Top_Of_Environment_Stack : constant System.Address;
   pragma Import (Asm, Top_Of_Environment_Stack, "__stack_end");
   --  Top of the stack to be used by the environment task

   Bottom_Of_Environment_Stack : constant System.Address;
   pragma Import (Asm, Bottom_Of_Environment_Stack, "__stack_start");
   --  Bottom of the stack to be used by the environment task

   ------------------
   -- Get_Affinity --
   ------------------

   function Get_Affinity (Thread : Thread_Id) return CPU_Range is
   begin
      return Thread.Base_CPU;
   end Get_Affinity;

   -------------
   -- Get_CPU --
   -------------

   function Get_CPU (Thread : Thread_Id) return CPU is
   begin
      if Thread.Base_CPU = Not_A_Specific_CPU then

         --  Return the implementation specific default CPU

         return CPU'First;
      else
         return CPU (Thread.Base_CPU);
      end if;
   end Get_CPU;

   --------------
   -- Get_ATCB --
   --------------

   function Get_ATCB return System.Address is
   begin
      --  This is not a light operation as there is a function call

      return Queues.Running_Thread.ATCB;
   end Get_ATCB;

   ------------------
   -- Get_Priority --
   ------------------

   function Get_Priority (Id : Thread_Id) return Integer is
   begin
      --  This function does not need to be protected by Enter_Kernel and
      --  Leave_Kernel, because the Active_Priority value is only updated by
      --  Set_Priority (atomically). Moreover, Active_Priority is marked as
      --  Volatile.

      return Id.Active_Priority;
   end Get_Priority;

   -----------------------
   -- Initialize_Thread --
   -----------------------

   procedure Initialize_Thread
     (Id            : Thread_Id;
      Code          : System.Address;
      Arg           : System.Address;
      Priority      : Integer;
      This_CPU      : System.Multiprocessors.CPU_Range;
      Stack_Top     : System.Address;
      Stack_Bottom  : System.Address) is
   begin
      --  Initialize task kernel data structure

      Id.Base_CPU := This_CPU;

      --  The active priority is initially equal to the base priority

      Id.Base_Priority   := Priority;
      Id.Active_Priority := Priority;

      --  Insert in the global list.

      Id.Global_List := Queues.Global_List;
      Queues.Global_List := Id;

      --  Insert task inside the ready list (as last within its priority)

      Queues.Insert (Id);

      --  Store stack information

      Id.Top_Of_Stack := Stack_Top;
      Id.Bottom_Of_Stack := Stack_Bottom;

      --  The initial state is Runnable

      Id.State := Runnable;

      --  Not currently in an interrupt handler

      Id.In_Interrupt := False;

      --  No wakeup has been yet signaled

      Id.Wakeup_Signaled := False;

      --  Initialize alarm status

      Id.Alarm_Time := System.BB.Time.Time'Last;
      Id.Next_Alarm := Null_Thread_Id;

      --  Reset execution time

      Id.Execution_Time :=
        System.BB.Time.Initial_Composite_Execution_Time;

      --  Initialize the task's register context

      Initialize_Context
        (Buffer          => Id.Context'Access,
         Program_Counter => Code,
         Argument        => Arg,
         Stack_Pointer   => (if System.Parameters.Stack_Grows_Down
                             then Id.Top_Of_Stack
                             else Id.Bottom_Of_Stack));
   end Initialize_Thread;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
     (Environment_Thread : Thread_Id;
      Main_Priority      : System.Any_Priority)
   is
      Main_CPU : constant System.Multiprocessors.CPU := Current_CPU;

   begin
      --  Perform some basic hardware initialization (clock, timer, and
      --  interrupt handlers).

      --  First initialize interrupt stacks

      Interrupts.Initialize_Interrupts;

      --  Then the CPU (which set interrupt stack pointer)

      Initialize_CPU;

      --  Then the devices

      Board_Support.Initialize_Board;
      Time.Initialize_Timers;

      --  Initialize internal queues and the environment task

      Protection.Enter_Kernel;

      --  The environment thread executes the main procedure of the program

      Initialize_Thread
        (Environment_Thread, Null_Address, Null_Address,
         Main_Priority, Main_CPU,
         Top_Of_Environment_Stack'Address,
         Bottom_Of_Environment_Stack'Address);

      Queues.Running_Thread_Table (Main_CPU) := Environment_Thread;

      --  The tasking executive is initialized

      Initialized := True;

      Protection.Leave_Kernel;
   end Initialize;

   ----------------------
   -- Initialize_Slave --
   ----------------------

   procedure Initialize_Slave
     (Idle_Thread   : Thread_Id;
      Idle_Priority : Integer;
      Stack_Address : System.Address;
      Stack_Size    : System.Storage_Elements.Storage_Offset)
   is
      CPU_Id : constant System.Multiprocessors.CPU := Current_CPU;

   begin
      Initialize_Thread
        (Idle_Thread, Null_Address, Null_Address,
         Idle_Priority, CPU_Id,
         Stack_Address + Stack_Size, Stack_Address);

      Queues.Running_Thread_Table (CPU_Id) := Idle_Thread;
   end Initialize_Slave;

   --------------
   -- Set_ATCB --
   --------------

   procedure Set_ATCB (Id : Thread_Id; ATCB : System.Address) is
   begin
      --  Set_ATCB is only called in the initialization of the task

      Id.ATCB := ATCB;
   end Set_ATCB;

   ------------------
   -- Set_Priority --
   ------------------

   procedure Set_Priority (Priority : Integer) is
   begin
      Protection.Enter_Kernel;

      --  The Ravenscar profile does not allow dynamic priority changes. Tasks
      --  change their priority only when they inherit the ceiling priority of
      --  a PO (Ceiling Locking policy). Hence, the task must be running when
      --  changing the priority. It is not possible to change the priority of
      --  another thread within the Ravenscar profile, so that is why
      --  Running_Thread is used.

      --  Priority changes are only possible as a result of inheriting the
      --  ceiling priority of a protected object. Hence, it can never be set
      --  a priority which is lower than the base priority of the thread.

      pragma Assert
        (Queues.Running_Thread /= Null_Thread_Id
          and then Priority >= Queues.Running_Thread.Base_Priority);

      Queues.Change_Priority (Queues.Running_Thread, Priority);

      Protection.Leave_Kernel;
   end Set_Priority;

   -----------
   -- Sleep --
   -----------

   procedure Sleep is
      Self_Id : constant Thread_Id := Queues.Running_Thread;
   begin
      Protection.Enter_Kernel;

      --  It can only suspend if it is executing

      pragma Assert
        (Self_Id /= Null_Thread_Id and then Self_Id.State = Runnable);

      if Self_Id.Wakeup_Signaled then

         --  Another thread has already executed a Wakeup on this thread so
         --  that we just consume the token and continue execution. It means
         --  that just before this call to Sleep the task has been preempted
         --  by the task that is awaking it. Hence the Sleep/Wakeup calls do
         --  not happen in the expected order, and we use the Wakeup_Signaled
         --  to flag this event so it is not lost.

         --  The situation is the following:

         --    1) a task A is going to wait in an entry for a barrier
         --    2) task A releases the lock associated to the protected object
         --    3) task A calls Sleep to suspend itself
         --    4) a task B opens the barrier and awakes task A (calls Wakeup)

         --  This is the expected sequence of events, but 4) may happen
         --  before 3) because task A decreases its priority in step 2) as a
         --  consequence of releasing the lock (Ceiling_Locking). Hence, task
         --  A may be preempted by task B in the window between releasing the
         --  protected object and actually suspending itself, and the Wakeup
         --  call by task B in 4) can happen before the Sleep call in 3).

         Self_Id.Wakeup_Signaled := False;

      else
         --  Update status

         Self_Id.State := Suspended;

         --  Extract from the list of ready threads

         Queues.Extract (Self_Id);

         --  The currently executing thread is now blocked, and it will leave
         --  the CPU when executing the Leave_Kernel procedure.

      end if;

      Protection.Leave_Kernel;

      --  Now the thread has been awaken again and it is executing

   end Sleep;

   -------------------
   -- Thread_Create --
   -------------------

   procedure Thread_Create
     (Id            : Thread_Id;
      Code          : System.Address;
      Arg           : System.Address;
      Priority      : Integer;
      Base_CPU      : System.Multiprocessors.CPU_Range;
      Stack_Address : System.Address;
      Stack_Size    : System.Storage_Elements.Storage_Offset)
   is
   begin
      Protection.Enter_Kernel;

      Initialize_Thread
        (Id, Code, Arg, Priority, Base_CPU,
         ((Stack_Address + Stack_Size) /
            Standard'Maximum_Alignment) * Standard'Maximum_Alignment,
         Stack_Address);

      Protection.Leave_Kernel;
   end Thread_Create;

   -----------------
   -- Thread_Self --
   -----------------

   function Thread_Self return Thread_Id is
   begin
      --  Return the thread that is currently executing

      return Queues.Running_Thread;
   end Thread_Self;

   ------------
   -- Wakeup --
   ------------

   procedure Wakeup (Id : Thread_Id) is
   begin
      Protection.Enter_Kernel;

      if Id.State = Suspended then

         --  The thread is already waiting so that we awake it

         --  Update status

         Id.State := Runnable;

         --  Insert the thread at the tail of its active priority so that the
         --  thread will resume execution.

         Queues.Insert (Id);

      else
         --  The thread is not yet waiting so that we just signal that the
         --  Wakeup command has been executed. We are waking up a task that
         --  is going to wait in an entry for a barrier, but before calling
         --  Sleep it has been preempted by the task awaking it.

         Id.Wakeup_Signaled := True;
      end if;

      pragma Assert (Id.State = Runnable);

      Protection.Leave_Kernel;
   end Wakeup;

end System.BB.Threads;