| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| -- -- |
| -- 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 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 1991-2001, Florida State University -- |
| -- -- |
| -- 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 2, 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. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNARL; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. It is -- |
| -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- |
| -- State University (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- RT GNU/Linux version |
| |
| -- ???? Later, look at what we might want to provide for interrupt |
| -- management. |
| |
| pragma Suppress (All_Checks); |
| |
| pragma Polling (Off); |
| -- Turn off polling, we do not want ATC polling to take place during |
| -- tasking operations. It causes infinite loops and other problems. |
| |
| with System.Machine_Code; |
| -- used for Asm |
| |
| with System.OS_Interface; |
| -- used for various types, constants, and operations |
| |
| with System.OS_Primitives; |
| -- used for Delay_Modes |
| |
| with System.Parameters; |
| -- used for Size_Type |
| |
| with System.Storage_Elements; |
| |
| with System.Tasking; |
| -- used for Ada_Task_Control_Block |
| -- Task_ID |
| |
| with Ada.Unchecked_Conversion; |
| |
| package body System.Task_Primitives.Operations is |
| |
| use System.Machine_Code, |
| System.OS_Interface, |
| System.OS_Primitives, |
| System.Parameters, |
| System.Tasking, |
| System.Storage_Elements; |
| |
| -------------------------------- |
| -- RT GNU/Linux specific Data -- |
| -------------------------------- |
| |
| -- Define two important parameters necessary for a GNU/Linux kernel module. |
| -- Any module that is going to be loaded into the kernel space needs these |
| -- parameters. |
| |
| Mod_Use_Count : Integer; |
| pragma Export (C, Mod_Use_Count, "mod_use_count_"); |
| -- for module usage tracking by the kernel |
| |
| type Aliased_String is array (Positive range <>) of aliased Character; |
| pragma Convention (C, Aliased_String); |
| |
| Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul; |
| pragma Export (C, Kernel_Version, "kernel_version"); |
| -- So that insmod can find the version number. |
| |
| -- The following procedures have their name specified by the GNU/Linux |
| -- module loader. Note that they simply correspond to adainit/adafinal. |
| |
| function Init_Module return Integer; |
| pragma Export (C, Init_Module, "init_module"); |
| |
| procedure Cleanup_Module; |
| pragma Export (C, Cleanup_Module, "cleanup_module"); |
| |
| ---------------- |
| -- Local Data -- |
| ---------------- |
| |
| LF : constant String := ASCII.LF & ASCII.Nul; |
| |
| LFHT : constant String := ASCII.LF & ASCII.HT; |
| -- used in inserted assembly code |
| |
| Max_Tasks : constant := 10; |
| -- ??? Eventually, this should probably be in System.Parameters. |
| |
| Known_Tasks : array (0 .. Max_Tasks) of Task_ID; |
| -- Global array of tasks read by gdb, and updated by Create_Task and |
| -- Finalize_TCB. It's from System.Tasking.Debug. We moved it here to |
| -- cut the dependence on that package. Consider moving it here or to |
| -- this package specification, permanently???? |
| |
| Max_Sensible_Delay : constant RTIME := |
| 365 * 24 * 60 * 60 * RT_TICKS_PER_SEC; |
| -- Max of one year delay, needed to prevent exceptions for large |
| -- delay values. It seems unlikely that any test will notice this |
| -- restriction. |
| -- ??? This is really declared in System.OS_Primitives, |
| -- and the type is Duration, here its type is RTIME. |
| |
| Tick_Count : constant := RT_TICKS_PER_SEC / 20; |
| Nano_Count : constant := 50_000_000; |
| -- two constants used in conversions between RTIME and Duration. |
| |
| Addr_Bytes : constant Storage_Offset := |
| System.Address'Max_Size_In_Storage_Elements; |
| -- number of bytes needed for storing an address. |
| |
| Guess : constant RTIME := 10; |
| -- an approximate amount of RTIME used in scheduler to awake a task having |
| -- its resume time within 'current time + Guess' |
| -- The value of 10 is estimated here and may need further refinement |
| |
| TCB_Array : array (0 .. Max_Tasks) |
| of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); |
| pragma Volatile_Components (TCB_Array); |
| |
| Available_TCBs : Task_ID; |
| pragma Atomic (Available_TCBs); |
| -- Head of linear linked list of available TCB's, linked using TCB's |
| -- LL.Next. This list is Initialized to contain a fixed number of tasks, |
| -- when the runtime system starts up. |
| |
| Current_Task : Task_ID; |
| pragma Export (C, Current_Task, "current_task"); |
| pragma Atomic (Current_Task); |
| -- This is the task currently running. We need the pragma here to specify |
| -- the link-name for Current_Task is "current_task", rather than the long |
| -- name (including the package name) that the Ada compiler would normally |
| -- generate. "current_task" is referenced in procedure Rt_Switch_To below |
| |
| Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); |
| -- Tail of the circular queue of ready to run tasks. |
| |
| Scheduler_Idle : Boolean := False; |
| -- True when the scheduler is idle (no task other than the idle task |
| -- is on the ready queue). |
| |
| In_Elab_Code : Boolean := True; |
| -- True when we are elaborating our application. |
| -- Init_Module will set this flag to false and never revert it. |
| |
| Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); |
| -- Header of the queue of delayed real-time tasks. |
| -- Timer_Queue.LL has to be initialized properly before being used |
| |
| Timer_Expired : Boolean := False; |
| -- flag to show whether the Timer_Queue needs to be checked |
| -- when it becomes true, it means there is a task in the |
| -- Timer_Queue having to be awakened and be moved to ready queue |
| |
| Environment_Task_ID : Task_ID; |
| -- A variable to hold Task_ID for the environment task. |
| -- Once initialized, this behaves as a constant. |
| -- In the current implementation, this is the task assigned permanently |
| -- as the regular GNU/Linux kernel. |
| |
| All_Tasks_L : aliased RTS_Lock; |
| -- See comments on locking rules in System.Tasking (spec). |
| |
| -- The followings are internal configuration constants needed. |
| Next_Serial_Number : Task_Serial_Number := 100; |
| pragma Volatile (Next_Serial_Number); |
| -- We start at 100, to reserve some special values for |
| -- using in error checking. |
| |
| GNU_Linux_Irq_State : Integer := 0; |
| -- This needs comments ??? |
| |
| type Duration_As_Integer is delta 1.0 |
| range -2.0**(Duration'Size - 1) .. 2.0**(Duration'Size - 1) - 1.0; |
| -- used for output RTIME value during debugging |
| |
| type Address_Ptr is access all System.Address; |
| pragma Convention (C, Address_Ptr); |
| |
| -------------------------------- |
| -- Local conversion functions -- |
| -------------------------------- |
| |
| function To_Task_ID is new |
| Ada.Unchecked_Conversion (System.Address, Task_ID); |
| |
| function To_Address is new |
| Ada.Unchecked_Conversion (Task_ID, System.Address); |
| |
| function RTIME_To_D_Int is new |
| Ada.Unchecked_Conversion (RTIME, Duration_As_Integer); |
| |
| function Raw_RTIME is new |
| Ada.Unchecked_Conversion (Duration, RTIME); |
| |
| function Raw_Duration is new |
| Ada.Unchecked_Conversion (RTIME, Duration); |
| |
| function To_Duration (T : RTIME) return Duration; |
| pragma Inline (To_Duration); |
| |
| function To_RTIME (D : Duration) return RTIME; |
| pragma Inline (To_RTIME); |
| |
| function To_Integer is new |
| Ada.Unchecked_Conversion (System.Parameters.Size_Type, Integer); |
| |
| function To_Address_Ptr is |
| new Ada.Unchecked_Conversion (System.Address, Address_Ptr); |
| |
| function To_RTS_Lock_Ptr is new |
| Ada.Unchecked_Conversion (Lock_Ptr, RTS_Lock_Ptr); |
| |
| ----------------------------------- |
| -- Local Subprogram Declarations -- |
| ----------------------------------- |
| |
| procedure Rt_Switch_To (Tsk : Task_ID); |
| pragma Inline (Rt_Switch_To); |
| -- switch from the 'current_task' to 'Tsk' |
| -- and 'Tsk' then becomes 'current_task' |
| |
| procedure R_Save_Flags (F : out Integer); |
| pragma Inline (R_Save_Flags); |
| -- save EFLAGS register to 'F' |
| |
| procedure R_Restore_Flags (F : Integer); |
| pragma Inline (R_Restore_Flags); |
| -- restore EFLAGS register from 'F' |
| |
| procedure R_Cli; |
| pragma Inline (R_Cli); |
| -- disable interrupts |
| |
| procedure R_Sti; |
| pragma Inline (R_Sti); |
| -- enable interrupts |
| |
| procedure Timer_Wrapper; |
| -- the timer handler. It sets Timer_Expired flag to True and |
| -- then calls Rt_Schedule |
| |
| procedure Rt_Schedule; |
| -- the scheduler |
| |
| procedure Insert_R (T : Task_ID); |
| pragma Inline (Insert_R); |
| -- insert 'T' into the tail of the ready queue for its active |
| -- priority |
| -- if original queue is 6 5 4 4 3 2 and T has priority of 4 |
| -- then after T is inserted the queue becomes 6 5 4 4 T 3 2 |
| |
| procedure Insert_RF (T : Task_ID); |
| pragma Inline (Insert_RF); |
| -- insert 'T' into the front of the ready queue for its active |
| -- priority |
| -- if original queue is 6 5 4 4 3 2 and T has priority of 4 |
| -- then after T is inserted the queue becomes 6 5 T 4 4 3 2 |
| |
| procedure Delete_R (T : Task_ID); |
| pragma Inline (Delete_R); |
| -- delete 'T' from the ready queue. If 'T' is not in any queue |
| -- the operation has no effect |
| |
| procedure Insert_T (T : Task_ID); |
| pragma Inline (Insert_T); |
| -- insert 'T' into the waiting queue according to its Resume_Time. |
| -- If there are tasks in the waiting queue that have the same |
| -- Resume_Time as 'T', 'T' is then inserted into the queue for |
| -- its active priority |
| |
| procedure Delete_T (T : Task_ID); |
| pragma Inline (Delete_T); |
| -- delete 'T' from the waiting queue. |
| |
| procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue; |
| pragma Inline (Move_Top_Task_From_Timer_Queue_To_Ready_Queue); |
| -- remove the task in the front of the waiting queue and insert it |
| -- into the tail of the ready queue for its active priority |
| |
| ------------------------- |
| -- Local Subprograms -- |
| ------------------------- |
| |
| procedure Rt_Switch_To (Tsk : Task_ID) is |
| begin |
| pragma Debug (Printk ("procedure Rt_Switch_To called" & LF)); |
| |
| Asm ( |
| "pushl %%eax" & LFHT & |
| "pushl %%ebp" & LFHT & |
| "pushl %%edi" & LFHT & |
| "pushl %%esi" & LFHT & |
| "pushl %%edx" & LFHT & |
| "pushl %%ecx" & LFHT & |
| "pushl %%ebx" & LFHT & |
| |
| "movl current_task, %%edx" & LFHT & |
| "cmpl $0, 36(%%edx)" & LFHT & |
| -- 36 is hard-coded, 36(%%edx) is actually |
| -- Current_Task.Common.LL.Uses_Fp |
| |
| "jz 25f" & LFHT & |
| "sub $108,%%esp" & LFHT & |
| "fsave (%%esp)" & LFHT & |
| "25: pushl $1f" & LFHT & |
| "movl %%esp, 32(%%edx)" & LFHT & |
| -- 32 is hard-coded, 32(%%edx) is actually |
| -- Current_Task.Common.LL.Stack |
| |
| "movl 32(%%ecx), %%esp" & LFHT & |
| -- 32 is hard-coded, 32(%%ecx) is actually Tsk.Common.LL.Stack. |
| -- Tsk is the task to be switched to |
| |
| "movl %%ecx, current_task" & LFHT & |
| "ret" & LFHT & |
| "1: cmpl $0, 36(%%ecx)" & LFHT & |
| -- 36(%%exc) is Tsk.Common.LL.Stack (hard coded) |
| "jz 26f" & LFHT & |
| "frstor (%%esp)" & LFHT & |
| "add $108,%%esp" & LFHT & |
| "26: popl %%ebx" & LFHT & |
| "popl %%ecx" & LFHT & |
| "popl %%edx" & LFHT & |
| "popl %%esi" & LFHT & |
| "popl %%edi" & LFHT & |
| "popl %%ebp" & LFHT & |
| "popl %%eax", |
| Outputs => No_Output_Operands, |
| Inputs => Task_ID'Asm_Input ("c", Tsk), |
| Clobber => "cx", |
| Volatile => True); |
| end Rt_Switch_To; |
| |
| procedure R_Save_Flags (F : out Integer) is |
| begin |
| Asm ( |
| "pushfl" & LFHT & |
| "popl %0", |
| Outputs => Integer'Asm_Output ("=g", F), |
| Inputs => No_Input_Operands, |
| Clobber => "memory", |
| Volatile => True); |
| end R_Save_Flags; |
| |
| procedure R_Restore_Flags (F : Integer) is |
| begin |
| Asm ( |
| "pushl %0" & LFHT & |
| "popfl", |
| Outputs => No_Output_Operands, |
| Inputs => Integer'Asm_Input ("g", F), |
| Clobber => "memory", |
| Volatile => True); |
| end R_Restore_Flags; |
| |
| procedure R_Sti is |
| begin |
| Asm ( |
| "sti", |
| Outputs => No_Output_Operands, |
| Inputs => No_Input_Operands, |
| Clobber => "memory", |
| Volatile => True); |
| end R_Sti; |
| |
| procedure R_Cli is |
| begin |
| Asm ( |
| "cli", |
| Outputs => No_Output_Operands, |
| Inputs => No_Input_Operands, |
| Clobber => "memory", |
| Volatile => True); |
| end R_Cli; |
| |
| -- A wrapper for Rt_Schedule, works as the timer handler |
| |
| procedure Timer_Wrapper is |
| begin |
| pragma Debug (Printk ("procedure Timer_Wrapper called" & LF)); |
| |
| Timer_Expired := True; |
| Rt_Schedule; |
| end Timer_Wrapper; |
| |
| procedure Rt_Schedule is |
| Now : RTIME; |
| Top_Task : Task_ID; |
| Flags : Integer; |
| |
| procedure Debug_Timer_Queue; |
| -- Check the state of the Timer Queue. |
| |
| procedure Debug_Timer_Queue is |
| begin |
| if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then |
| Printk ("Timer_Queue not empty" & LF); |
| end if; |
| |
| if To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < |
| Now + Guess |
| then |
| Printk ("and need to move top task to ready queue" & LF); |
| end if; |
| end Debug_Timer_Queue; |
| |
| begin |
| pragma Debug (Printk ("procedure Rt_Schedule called" & LF)); |
| |
| -- Scheduler_Idle means that this call comes from an interrupt |
| -- handler (e.g timer) that interrupted the idle loop below. |
| |
| if Scheduler_Idle then |
| return; |
| end if; |
| |
| <<Idle>> |
| R_Save_Flags (Flags); |
| R_Cli; |
| |
| Scheduler_Idle := False; |
| |
| if Timer_Expired then |
| pragma Debug (Printk ("Timer expired" & LF)); |
| Timer_Expired := False; |
| |
| -- Check for expired time delays. |
| Now := Rt_Get_Time; |
| |
| -- Need another (circular) queue for delayed tasks, this one ordered |
| -- by wakeup time, so the one at the front has the earliest resume |
| -- time. Wake up all the tasks sleeping on time delays that should |
| -- be awakened at this time. |
| |
| -- ??? This is not very good, since we may waste time here waking |
| -- up a bunch of lower priority tasks, adding to the blocking time |
| -- of higher priority ready tasks, but we don't see how to get |
| -- around this without adding more wasted time elsewhere. |
| |
| pragma Debug (Debug_Timer_Queue); |
| |
| while Timer_Queue.Common.LL.Succ /= Timer_Queue'Address and then |
| To_Task_ID |
| (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < Now + Guess |
| loop |
| To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.State := |
| RT_TASK_READY; |
| Move_Top_Task_From_Timer_Queue_To_Ready_Queue; |
| end loop; |
| |
| -- Arm the timer if necessary. |
| -- ??? This may be wasteful, if the tasks on the timer queue are |
| -- of lower priority than the current task's priority. The problem |
| -- is that we can't tell this without scanning the whole timer |
| -- queue. This scanning takes extra time. |
| |
| if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then |
| -- Timer_Queue is not empty, so set the timer to interrupt at |
| -- the next resume time. The Wakeup procedure must also do this, |
| -- and must do it while interrupts are disabled so that there is |
| -- no danger of interleaving with this code. |
| Rt_Set_Timer |
| (To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time); |
| else |
| Rt_No_Timer; |
| end if; |
| end if; |
| |
| Top_Task := To_Task_ID (Idle_Task.Common.LL.Succ); |
| |
| -- If the ready queue is empty, the kernel has to wait until the timer |
| -- or another interrupt makes a task ready. |
| |
| if Top_Task = To_Task_ID (Idle_Task'Address) then |
| Scheduler_Idle := True; |
| R_Restore_Flags (Flags); |
| pragma Debug (Printk ("!!!kernel idle!!!" & LF)); |
| goto Idle; |
| end if; |
| |
| if Top_Task = Current_Task then |
| pragma Debug (Printk ("Rt_Schedule: Top_Task = Current_Task" & LF)); |
| -- if current task continues, just return. |
| |
| R_Restore_Flags (Flags); |
| return; |
| end if; |
| |
| if Top_Task = Environment_Task_ID then |
| pragma Debug (Printk |
| ("Rt_Schedule: Top_Task = Environment_Task" & LF)); |
| -- If there are no RT tasks ready, we execute the regular |
| -- GNU/Linux kernel, and allow the regular GNU/Linux interrupt |
| -- handlers to preempt the current task again. |
| |
| if not In_Elab_Code then |
| SFIF := GNU_Linux_Irq_State; |
| end if; |
| |
| elsif Current_Task = Environment_Task_ID then |
| pragma Debug (Printk |
| ("Rt_Schedule: Current_Task = Environment_Task" & LF)); |
| -- We are going to preempt the regular GNU/Linux kernel to |
| -- execute an RT task, so don't allow the regular GNU/Linux |
| -- interrupt handlers to preempt the current task any more. |
| |
| GNU_Linux_Irq_State := SFIF; |
| SFIF := 0; |
| end if; |
| |
| Top_Task.Common.LL.State := RT_TASK_READY; |
| Rt_Switch_To (Top_Task); |
| R_Restore_Flags (Flags); |
| end Rt_Schedule; |
| |
| procedure Insert_R (T : Task_ID) is |
| Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ); |
| begin |
| pragma Debug (Printk ("procedure Insert_R called" & LF)); |
| |
| pragma Assert (T.Common.LL.Succ = To_Address (T)); |
| pragma Assert (T.Common.LL.Pred = To_Address (T)); |
| |
| -- T is inserted in the queue between a task that has higher |
| -- or the same Active_Priority as T and a task that has lower |
| -- Active_Priority than T |
| |
| while Q /= To_Task_ID (Idle_Task'Address) |
| and then T.Common.LL.Active_Priority <= Q.Common.LL.Active_Priority |
| loop |
| Q := To_Task_ID (Q.Common.LL.Succ); |
| end loop; |
| |
| -- Q is successor of T |
| |
| T.Common.LL.Succ := To_Address (Q); |
| T.Common.LL.Pred := Q.Common.LL.Pred; |
| To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); |
| Q.Common.LL.Pred := To_Address (T); |
| end Insert_R; |
| |
| procedure Insert_RF (T : Task_ID) is |
| Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ); |
| begin |
| pragma Debug (Printk ("procedure Insert_RF called" & LF)); |
| |
| pragma Assert (T.Common.LL.Succ = To_Address (T)); |
| pragma Assert (T.Common.LL.Pred = To_Address (T)); |
| |
| -- T is inserted in the queue between a task that has higher |
| -- Active_Priority as T and a task that has lower or the same |
| -- Active_Priority as T |
| |
| while Q /= To_Task_ID (Idle_Task'Address) and then |
| T.Common.LL.Active_Priority < Q.Common.LL.Active_Priority |
| loop |
| Q := To_Task_ID (Q.Common.LL.Succ); |
| end loop; |
| |
| -- Q is successor of T |
| |
| T.Common.LL.Succ := To_Address (Q); |
| T.Common.LL.Pred := Q.Common.LL.Pred; |
| To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); |
| Q.Common.LL.Pred := To_Address (T); |
| end Insert_RF; |
| |
| procedure Delete_R (T : Task_ID) is |
| Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred); |
| Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ); |
| |
| begin |
| pragma Debug (Printk ("procedure Delete_R called" & LF)); |
| |
| -- checking whether T is in the queue is not necessary because |
| -- if T is not in the queue, following statements changes |
| -- nothing. But T cannot be in the Timer_Queue, otherwise |
| -- activate the check below, note that checking whether T is |
| -- in a queue is a relatively expensive operation |
| |
| Tpred.Common.LL.Succ := To_Address (Tsucc); |
| Tsucc.Common.LL.Pred := To_Address (Tpred); |
| T.Common.LL.Succ := To_Address (T); |
| T.Common.LL.Pred := To_Address (T); |
| end Delete_R; |
| |
| procedure Insert_T (T : Task_ID) is |
| Q : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ); |
| begin |
| pragma Debug (Printk ("procedure Insert_T called" & LF)); |
| |
| pragma Assert (T.Common.LL.Succ = To_Address (T)); |
| |
| while Q /= To_Task_ID (Timer_Queue'Address) and then |
| T.Common.LL.Resume_Time > Q.Common.LL.Resume_Time |
| loop |
| Q := To_Task_ID (Q.Common.LL.Succ); |
| end loop; |
| |
| -- Q is the task that has Resume_Time equal to or greater than that |
| -- of T. If they have the same Resume_Time, continue looking for the |
| -- location T is to be inserted using its Active_Priority |
| |
| while Q /= To_Task_ID (Timer_Queue'Address) and then |
| T.Common.LL.Resume_Time = Q.Common.LL.Resume_Time |
| loop |
| exit when T.Common.LL.Active_Priority > Q.Common.LL.Active_Priority; |
| Q := To_Task_ID (Q.Common.LL.Succ); |
| end loop; |
| |
| -- Q is successor of T |
| |
| T.Common.LL.Succ := To_Address (Q); |
| T.Common.LL.Pred := Q.Common.LL.Pred; |
| To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); |
| Q.Common.LL.Pred := To_Address (T); |
| end Insert_T; |
| |
| procedure Delete_T (T : Task_ID) is |
| Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred); |
| Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ); |
| |
| begin |
| pragma Debug (Printk ("procedure Delete_T called" & LF)); |
| |
| pragma Assert (T /= To_Task_ID (Timer_Queue'Address)); |
| |
| Tpred.Common.LL.Succ := To_Address (Tsucc); |
| Tsucc.Common.LL.Pred := To_Address (Tpred); |
| T.Common.LL.Succ := To_Address (T); |
| T.Common.LL.Pred := To_Address (T); |
| end Delete_T; |
| |
| procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue is |
| Top_Task : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ); |
| begin |
| pragma Debug (Printk ("procedure Move_Top_Task called" & LF)); |
| |
| if Top_Task /= To_Task_ID (Timer_Queue'Address) then |
| Delete_T (Top_Task); |
| Top_Task.Common.LL.State := RT_TASK_READY; |
| Insert_R (Top_Task); |
| end if; |
| end Move_Top_Task_From_Timer_Queue_To_Ready_Queue; |
| |
| ---------- |
| -- Self -- |
| ---------- |
| |
| function Self return Task_ID is |
| begin |
| pragma Debug (Printk ("function Self called" & LF)); |
| |
| return Current_Task; |
| end Self; |
| |
| --------------------- |
| -- Initialize_Lock -- |
| --------------------- |
| |
| procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is |
| begin |
| pragma Debug (Printk ("procedure Initialize_Lock called" & LF)); |
| |
| L.Ceiling_Priority := Prio; |
| L.Owner := System.Null_Address; |
| end Initialize_Lock; |
| |
| procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is |
| begin |
| pragma Debug (Printk ("procedure Initialize_Lock (RTS) called" & LF)); |
| |
| L.Ceiling_Priority := System.Any_Priority'Last; |
| L.Owner := System.Null_Address; |
| end Initialize_Lock; |
| |
| ------------------- |
| -- Finalize_Lock -- |
| ------------------- |
| |
| procedure Finalize_Lock (L : access Lock) is |
| begin |
| pragma Debug (Printk ("procedure Finalize_Lock called" & LF)); |
| null; |
| end Finalize_Lock; |
| |
| procedure Finalize_Lock (L : access RTS_Lock) is |
| begin |
| pragma Debug (Printk ("procedure Finalize_Lock (RTS) called" & LF)); |
| null; |
| end Finalize_Lock; |
| |
| ---------------- |
| -- Write_Lock -- |
| ---------------- |
| |
| procedure Write_Lock |
| (L : access Lock; |
| Ceiling_Violation : out Boolean) |
| is |
| Prio : constant System.Any_Priority := |
| Current_Task.Common.LL.Active_Priority; |
| begin |
| pragma Debug (Printk ("procedure Write_Lock called" & LF)); |
| |
| Ceiling_Violation := False; |
| |
| if Prio > L.Ceiling_Priority then |
| -- Ceiling violation. |
| -- This should never happen, unless something is seriously |
| -- wrong with task T or the entire run-time system. |
| -- ???? extreme error recovery, e.g. shut down the system or task |
| |
| Ceiling_Violation := True; |
| pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF)); |
| return; |
| end if; |
| |
| L.Pre_Locking_Priority := Prio; |
| L.Owner := To_Address (Current_Task); |
| Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority; |
| |
| if Current_Task.Common.LL.Outer_Lock = null then |
| -- If this lock is not nested, record a pointer to it. |
| |
| Current_Task.Common.LL.Outer_Lock := |
| To_RTS_Lock_Ptr (L.all'Unchecked_Access); |
| end if; |
| end Write_Lock; |
| |
| procedure Write_Lock (L : access RTS_Lock) is |
| Prio : constant System.Any_Priority := |
| Current_Task.Common.LL.Active_Priority; |
| |
| begin |
| pragma Debug (Printk ("procedure Write_Lock (RTS) called" & LF)); |
| |
| if Prio > L.Ceiling_Priority then |
| -- Ceiling violation. |
| -- This should never happen, unless something is seriously |
| -- wrong with task T or the entire runtime system. |
| -- ???? extreme error recovery, e.g. shut down the system or task |
| |
| Printk ("Ceiling Violation in Write_Lock (RTS)" & LF); |
| return; |
| end if; |
| |
| L.Pre_Locking_Priority := Prio; |
| L.Owner := To_Address (Current_Task); |
| Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority; |
| |
| if Current_Task.Common.LL.Outer_Lock = null then |
| Current_Task.Common.LL.Outer_Lock := L.all'Unchecked_Access; |
| end if; |
| end Write_Lock; |
| |
| procedure Write_Lock (T : Task_ID) is |
| Prio : constant System.Any_Priority := |
| Current_Task.Common.LL.Active_Priority; |
| |
| begin |
| pragma Debug (Printk ("procedure Write_Lock (Task_ID) called" & LF)); |
| |
| if Prio > T.Common.LL.L.Ceiling_Priority then |
| -- Ceiling violation. |
| -- This should never happen, unless something is seriously |
| -- wrong with task T or the entire runtime system. |
| -- ???? extreme error recovery, e.g. shut down the system or task |
| |
| Printk ("Ceiling Violation in Write_Lock (Task)" & LF); |
| return; |
| end if; |
| |
| T.Common.LL.L.Pre_Locking_Priority := Prio; |
| T.Common.LL.L.Owner := To_Address (Current_Task); |
| Current_Task.Common.LL.Active_Priority := T.Common.LL.L.Ceiling_Priority; |
| |
| if Current_Task.Common.LL.Outer_Lock = null then |
| Current_Task.Common.LL.Outer_Lock := T.Common.LL.L'Access; |
| end if; |
| end Write_Lock; |
| |
| --------------- |
| -- Read_Lock -- |
| --------------- |
| |
| procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is |
| begin |
| pragma Debug (Printk ("procedure Read_Lock called" & LF)); |
| Write_Lock (L, Ceiling_Violation); |
| end Read_Lock; |
| |
| ------------ |
| -- Unlock -- |
| ------------ |
| |
| procedure Unlock (L : access Lock) is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Unlock called" & LF)); |
| |
| if L.Owner /= To_Address (Current_Task) then |
| -- ...error recovery |
| |
| null; |
| Printk ("The caller is not the owner of the lock" & LF); |
| return; |
| end if; |
| |
| L.Owner := System.Null_Address; |
| |
| -- Now that the lock is released, lower own priority, |
| |
| if Current_Task.Common.LL.Outer_Lock = |
| To_RTS_Lock_Ptr (L.all'Unchecked_Access) |
| then |
| -- This lock is the outer-most one, reset own priority to |
| -- Current_Priority; |
| |
| Current_Task.Common.LL.Active_Priority := |
| Current_Task.Common.Current_Priority; |
| Current_Task.Common.LL.Outer_Lock := null; |
| |
| else |
| -- If this lock is nested, pop the old active priority. |
| |
| Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority; |
| end if; |
| |
| -- Reschedule the task if necessary. Note we only need to reschedule |
| -- the task if its Active_Priority becomes less than the one following |
| -- it. The check depends on the fact that Environment_Task (tail of |
| -- the ready queue) has the lowest Active_Priority |
| |
| if Current_Task.Common.LL.Active_Priority |
| < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority |
| then |
| R_Save_Flags (Flags); |
| R_Cli; |
| Delete_R (Current_Task); |
| Insert_RF (Current_Task); |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| end if; |
| end Unlock; |
| |
| procedure Unlock (L : access RTS_Lock) is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF)); |
| |
| if L.Owner /= To_Address (Current_Task) then |
| null; |
| Printk ("The caller is not the owner of the lock" & LF); |
| return; |
| end if; |
| |
| L.Owner := System.Null_Address; |
| |
| if Current_Task.Common.LL.Outer_Lock = L.all'Unchecked_Access then |
| Current_Task.Common.LL.Active_Priority := |
| Current_Task.Common.Current_Priority; |
| Current_Task.Common.LL.Outer_Lock := null; |
| |
| else |
| Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority; |
| end if; |
| |
| -- Reschedule the task if necessary |
| |
| if Current_Task.Common.LL.Active_Priority |
| < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority |
| then |
| R_Save_Flags (Flags); |
| R_Cli; |
| Delete_R (Current_Task); |
| Insert_RF (Current_Task); |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| end if; |
| end Unlock; |
| |
| procedure Unlock (T : Task_ID) is |
| begin |
| pragma Debug (Printk ("procedure Unlock (Task_ID) called" & LF)); |
| Unlock (T.Common.LL.L'Access); |
| end Unlock; |
| |
| ----------- |
| -- Sleep -- |
| ----------- |
| |
| -- Unlock Self_ID.Common.LL.L and suspend Self_ID, atomically. |
| -- Before return, lock Self_ID.Common.LL.L again |
| -- Self_ID can only be reactivated by calling Wakeup. |
| -- Unlock code is repeated intentionally. |
| |
| procedure Sleep |
| (Self_ID : Task_ID; |
| Reason : ST.Task_States) |
| is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Sleep called" & LF)); |
| |
| -- Note that Self_ID is actually Current_Task, that is, only the |
| -- task that is running can put itself into sleep. To preserve |
| -- consistency, we use Self_ID throughout the code here |
| |
| Self_ID.Common.State := Reason; |
| Self_ID.Common.LL.State := RT_TASK_DORMANT; |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| |
| Delete_R (Self_ID); |
| |
| -- Arrange to unlock Self_ID's ATCB lock. The following check |
| -- may be unnecessary because the specification of Sleep says |
| -- the caller shoud hold its own ATCB lock before calling Sleep |
| |
| if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then |
| Self_ID.Common.LL.L.Owner := System.Null_Address; |
| |
| if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.Current_Priority; |
| Self_ID.Common.LL.Outer_Lock := null; |
| |
| else |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.LL.L.Pre_Locking_Priority; |
| end if; |
| end if; |
| |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| |
| -- Before leave, regain the lock |
| |
| Write_Lock (Self_ID); |
| end Sleep; |
| |
| ----------------- |
| -- Timed_Sleep -- |
| ----------------- |
| |
| -- Arrange to be awakened after/at Time (depending on Mode) then Unlock |
| -- Self_ID.Common.LL.L and suspend self. If the timeout expires first, |
| -- that should awaken the task. If it's awakened (by some other task |
| -- calling Wakeup) before the timeout expires, the timeout should be |
| -- cancelled. |
| |
| -- This is for use within the run-time system, so abort is |
| -- assumed to be already deferred, and the caller should be |
| -- holding its own ATCB lock. |
| |
| procedure Timed_Sleep |
| (Self_ID : Task_ID; |
| Time : Duration; |
| Mode : ST.Delay_Modes; |
| Reason : Task_States; |
| Timedout : out Boolean; |
| Yielded : out Boolean) |
| is |
| Flags : Integer; |
| Abs_Time : RTIME; |
| |
| begin |
| pragma Debug (Printk ("procedure Timed_Sleep called" & LF)); |
| |
| Timedout := True; |
| Yielded := False; |
| -- ??? These two boolean seems not relevant here |
| |
| if Mode = Relative then |
| Abs_Time := To_RTIME (Time) + Rt_Get_Time; |
| else |
| Abs_Time := To_RTIME (Time); |
| end if; |
| |
| Self_ID.Common.LL.Resume_Time := Abs_Time; |
| Self_ID.Common.LL.State := RT_TASK_DELAYED; |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| Delete_R (Self_ID); |
| Insert_T (Self_ID); |
| |
| -- Check if the timer needs to be set |
| |
| if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then |
| Rt_Set_Timer (Abs_Time); |
| end if; |
| |
| -- Another way to do it |
| -- |
| -- if Abs_Time < |
| -- To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time |
| -- then |
| -- Rt_Set_Timer (Abs_Time); |
| -- end if; |
| |
| -- Arrange to unlock Self_ID's ATCB lock. see comments in Sleep |
| |
| if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then |
| Self_ID.Common.LL.L.Owner := System.Null_Address; |
| |
| if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.Current_Priority; |
| Self_ID.Common.LL.Outer_Lock := null; |
| |
| else |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.LL.L.Pre_Locking_Priority; |
| end if; |
| end if; |
| |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| |
| -- Before leaving, regain the lock |
| |
| Write_Lock (Self_ID); |
| end Timed_Sleep; |
| |
| ----------------- |
| -- Timed_Delay -- |
| ----------------- |
| |
| -- This is for use in implementing delay statements, so we assume |
| -- the caller is not abort-deferred and is holding no locks. |
| -- Self_ID can only be awakened after the timeout, no Wakeup on it. |
| |
| procedure Timed_Delay |
| (Self_ID : Task_ID; |
| Time : Duration; |
| Mode : ST.Delay_Modes) |
| is |
| Flags : Integer; |
| Abs_Time : RTIME; |
| |
| begin |
| pragma Debug (Printk ("procedure Timed_Delay called" & LF)); |
| |
| -- Only the little window between deferring abort and |
| -- locking Self_ID is the reason we need to |
| -- check for pending abort and priority change below! :( |
| |
| Write_Lock (Self_ID); |
| |
| -- Take the lock in case its ATCB needs to be modified |
| |
| if Mode = Relative then |
| Abs_Time := To_RTIME (Time) + Rt_Get_Time; |
| else |
| Abs_Time := To_RTIME (Time); |
| end if; |
| |
| Self_ID.Common.LL.Resume_Time := Abs_Time; |
| Self_ID.Common.LL.State := RT_TASK_DELAYED; |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| Delete_R (Self_ID); |
| Insert_T (Self_ID); |
| |
| -- Check if the timer needs to be set |
| |
| if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then |
| Rt_Set_Timer (Abs_Time); |
| end if; |
| |
| -- Arrange to unlock Self_ID's ATCB lock. |
| -- Note that the code below is slightly different from Unlock, so |
| -- it is more than inline it. |
| |
| if To_Task_ID (Self_ID.Common.LL.L.Owner) = Self_ID then |
| Self_ID.Common.LL.L.Owner := System.Null_Address; |
| |
| if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.Current_Priority; |
| Self_ID.Common.LL.Outer_Lock := null; |
| |
| else |
| Self_ID.Common.LL.Active_Priority := |
| Self_ID.Common.LL.L.Pre_Locking_Priority; |
| end if; |
| end if; |
| |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| end Timed_Delay; |
| |
| --------------------- |
| -- Monotonic_Clock -- |
| --------------------- |
| |
| -- RTIME is represented as a 64-bit signed count of ticks, |
| -- where there are 1_193_180 ticks per second. |
| |
| -- Let T be a count of ticks and N the corresponding count of nanoseconds. |
| -- From the following relationship |
| -- T / (ticks_per_second) = N / (ns_per_second) |
| -- where ns_per_second is 1_000_000_000 (number of nanoseconds in |
| -- a second), we get |
| -- T * (ns_per_second) = N * (ticks_per_second) |
| -- or |
| -- T * 1_000_000_000 = N * 1_193_180 |
| -- which can be reduced to |
| -- T * 50_000_000 = N * 59_659 |
| -- Let Nano_Count = 50_000_000 and Tick_Count = 59_659, we then have |
| -- T * Nano_Count = N * Tick_Count |
| |
| -- IMPORTANT FACT: |
| -- These numbers are small enough that we can do arithmetic |
| -- on them without overflowing 64 bits. To see this, observe |
| |
| -- 10**3 = 1000 < 1024 = 2**10 |
| -- Tick_Count < 60 * 1000 < 64 * 1024 < 2**16 |
| -- Nano_Count < 50 * 1000 * 1000 < 64 * 1024 * 1024 < 2**26 |
| |
| -- It follows that if 0 <= R < Tick_Count, we can compute |
| -- R * Nano_Count < 2**42 without overflow in 64 bits. |
| -- Similarly, if 0 <= R < Nano_Count, we can compute |
| -- R * Tick_Count < 2**42 without overflow in 64 bits. |
| |
| -- GNAT represents Duration as a count of nanoseconds internally. |
| |
| -- To convert T from RTIME to Duration, let |
| -- Q = T / Tick_Count, with truncation |
| -- R = T - Q * Tick_Count, the remainder 0 <= R < Tick_Count |
| -- so |
| -- N * Tick_Count |
| -- = T * Nano_Count - Q * Tick_Count * Nano_Count |
| -- + Q * Tick_Count * Nano_Count |
| -- = (T - Q * Tick_Count) * Nano_Count |
| -- + (Q * Nano_Count) * Tick_Count |
| -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count |
| |
| -- Now, let |
| -- Q1 = R * Nano_Count / Tick_Count, with truncation |
| -- R1 = R * Nano_Count - Q1 * Tick_Count, 0 <= R1 <Tick_Count |
| -- R * Nano_Count = Q1 * Tick_Count + R1 |
| -- so |
| -- N * Tick_Count |
| -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count |
| -- = Q1 * Tick_Count + R1 + (Q * Nano_Count) * Tick_Count |
| -- = R1 + (Q * Nano_Count + Q1) * Tick_Count |
| -- and |
| -- N = Q * Nano_Count + Q1 + R1 /Tick_Count, |
| -- where 0 <= R1 /Tick_Count < 1 |
| |
| function To_Duration (T : RTIME) return Duration is |
| Q, Q1, RN : RTIME; |
| begin |
| Q := T / Tick_Count; |
| RN := (T - Q * Tick_Count) * Nano_Count; |
| Q1 := RN / Tick_Count; |
| return Raw_Duration (Q * Nano_Count + Q1); |
| end To_Duration; |
| |
| -- To convert D from Duration to RTIME, |
| -- Let D be a Duration value, and N be the representation of D as an |
| -- integer count of nanoseconds. Let |
| -- Q = N / Nano_Count, with truncation |
| -- R = N - Q * Nano_Count, the remainder 0 <= R < Nano_Count |
| -- so |
| -- T * Nano_Count |
| -- = N * Tick_Count - Q * Nano_Count * Tick_Count |
| -- + Q * Nano_Count * Tick_Count |
| -- = (N - Q * Nano_Count) * Tick_Count |
| -- + (Q * Tick_Count) * Nano_Count |
| -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count |
| -- Now, let |
| -- Q1 = R * Tick_Count / Nano_Count, with truncation |
| -- R1 = R * Tick_Count - Q1 * Nano_Count, 0 <= R1 < Nano_Count |
| -- R * Tick_Count = Q1 * Nano_Count + R1 |
| -- so |
| -- T * Nano_Count |
| -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count |
| -- = Q1 * Nano_Count + R1 + (Q * Tick_Count) * Nano_Count |
| -- = (Q * Tick_Count + Q1) * Nano_Count + R1 |
| -- and |
| -- T = Q * Tick_Count + Q1 + R1 / Nano_Count, |
| -- where 0 <= R1 / Nano_Count < 1 |
| |
| function To_RTIME (D : Duration) return RTIME is |
| N : RTIME := Raw_RTIME (D); |
| Q, Q1, RT : RTIME; |
| |
| begin |
| Q := N / Nano_Count; |
| RT := (N - Q * Nano_Count) * Tick_Count; |
| Q1 := RT / Nano_Count; |
| return Q * Tick_Count + Q1; |
| end To_RTIME; |
| |
| function Monotonic_Clock return Duration is |
| begin |
| pragma Debug (Printk ("procedure Clock called" & LF)); |
| |
| return To_Duration (Rt_Get_Time); |
| end Monotonic_Clock; |
| |
| ------------------- |
| -- RT_Resolution -- |
| ------------------- |
| |
| function RT_Resolution return Duration is |
| begin |
| return 10#1.0#E-6; |
| end RT_Resolution; |
| |
| ------------ |
| -- Wakeup -- |
| ------------ |
| |
| procedure Wakeup (T : Task_ID; Reason : ST.Task_States) is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Wakeup called" & LF)); |
| |
| T.Common.State := Reason; |
| T.Common.LL.State := RT_TASK_READY; |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| |
| if Timer_Queue.Common.LL.Succ = To_Address (T) then |
| -- T is the first task in Timer_Queue, further check |
| |
| if T.Common.LL.Succ = Timer_Queue'Address then |
| -- T is the only task in Timer_Queue, so deactivate timer |
| |
| Rt_No_Timer; |
| |
| else |
| -- T is the first task in Timer_Queue, so set timer to T's |
| -- successor's Resume_Time |
| |
| Rt_Set_Timer (To_Task_ID (T.Common.LL.Succ).Common.LL.Resume_Time); |
| end if; |
| end if; |
| |
| Delete_T (T); |
| |
| -- If T is in Timer_Queue, T is removed. If not, nothing happened |
| |
| Insert_R (T); |
| R_Restore_Flags (Flags); |
| |
| Rt_Schedule; |
| end Wakeup; |
| |
| ----------- |
| -- Yield -- |
| ----------- |
| |
| procedure Yield (Do_Yield : Boolean := True) is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Yield called" & LF)); |
| |
| pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address)); |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| Delete_R (Current_Task); |
| Insert_R (Current_Task); |
| |
| -- Remove Current_Task from the top of the Ready_Queue |
| -- and reinsert it back at proper position (the end of |
| -- tasks with the same active priority). |
| |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| end Yield; |
| |
| ------------------ |
| -- Set_Priority -- |
| ------------------ |
| |
| -- This version implicitly assume that T is the Current_Task |
| |
| procedure Set_Priority |
| (T : Task_ID; |
| Prio : System.Any_Priority; |
| Loss_Of_Inheritance : Boolean := False) |
| is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Set_Priority called" & LF)); |
| pragma Assert (T = Self); |
| |
| T.Common.Current_Priority := Prio; |
| |
| if T.Common.LL.Outer_Lock /= null then |
| -- If the task T is holding any lock, defer the priority change |
| -- until the lock is released. That is, T's Active_Priority will |
| -- be set to Prio after it unlocks the outer-most lock. See |
| -- Unlock for detail. |
| -- Nothing needs to be done here for this case |
| |
| null; |
| else |
| -- If T is not holding any lock, change the priority right away. |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| T.Common.LL.Active_Priority := Prio; |
| Delete_R (T); |
| Insert_RF (T); |
| |
| -- Insert at the front of the queue for its new priority |
| |
| R_Restore_Flags (Flags); |
| end if; |
| |
| Rt_Schedule; |
| end Set_Priority; |
| |
| ------------------ |
| -- Get_Priority -- |
| ------------------ |
| |
| function Get_Priority (T : Task_ID) return System.Any_Priority is |
| begin |
| pragma Debug (Printk ("procedure Get_Priority called" & LF)); |
| |
| return T.Common.Current_Priority; |
| end Get_Priority; |
| |
| ---------------- |
| -- Enter_Task -- |
| ---------------- |
| |
| -- Do any target-specific initialization that is needed for a new task |
| -- that has to be done by the task itself. This is called from the task |
| -- wrapper, immediately after the task starts execution. |
| |
| procedure Enter_Task (Self_ID : Task_ID) is |
| begin |
| -- Use this as "hook" to re-enable interrupts. |
| pragma Debug (Printk ("procedure Enter_Task called" & LF)); |
| |
| R_Sti; |
| end Enter_Task; |
| |
| ---------------- |
| -- New_ATCB -- |
| ---------------- |
| |
| function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is |
| T : constant Task_ID := Available_TCBs; |
| begin |
| pragma Debug (Printk ("function New_ATCB called" & LF)); |
| |
| if Entry_Num /= 0 then |
| -- We are preallocating all TCBs, so they must all have the |
| -- same number of entries, which means the value of |
| -- Entry_Num must be bounded. We probably could choose a |
| -- non-zero upper bound here, but the Ravenscar Profile |
| -- specifies that there be no task entries. |
| -- ??? |
| -- Later, do something better for recovery from this error. |
| |
| null; |
| end if; |
| |
| if T /= null then |
| Available_TCBs := To_Task_ID (T.Common.LL.Next); |
| T.Common.LL.Next := System.Null_Address; |
| Known_Tasks (T.Known_Tasks_Index) := T; |
| end if; |
| |
| return T; |
| end New_ATCB; |
| |
| ---------------------- |
| -- Initialize_TCB -- |
| ---------------------- |
| |
| procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is |
| begin |
| pragma Debug (Printk ("procedure Initialize_TCB called" & LF)); |
| |
| -- Give the task a unique serial number. |
| |
| Self_ID.Serial_Number := Next_Serial_Number; |
| Next_Serial_Number := Next_Serial_Number + 1; |
| pragma Assert (Next_Serial_Number /= 0); |
| |
| Self_ID.Common.LL.L.Ceiling_Priority := System.Any_Priority'Last; |
| Self_ID.Common.LL.L.Owner := System.Null_Address; |
| Succeeded := True; |
| end Initialize_TCB; |
| |
| ----------------- |
| -- Create_Task -- |
| ----------------- |
| |
| procedure Create_Task |
| (T : Task_ID; |
| Wrapper : System.Address; |
| Stack_Size : System.Parameters.Size_Type; |
| Priority : System.Any_Priority; |
| Succeeded : out Boolean) |
| is |
| Adjusted_Stack_Size : Integer; |
| Bottom : System.Address; |
| Flags : Integer; |
| |
| begin |
| pragma Debug (Printk ("procedure Create_Task called" & LF)); |
| |
| Succeeded := True; |
| |
| if T.Common.LL.Magic = RT_TASK_MAGIC then |
| Succeeded := False; |
| return; |
| end if; |
| |
| if Stack_Size = Unspecified_Size then |
| Adjusted_Stack_Size := To_Integer (Default_Stack_Size); |
| elsif Stack_Size < Minimum_Stack_Size then |
| Adjusted_Stack_Size := To_Integer (Minimum_Stack_Size); |
| else |
| Adjusted_Stack_Size := To_Integer (Stack_Size); |
| end if; |
| |
| Bottom := Kmalloc (Adjusted_Stack_Size, GFP_KERNEL); |
| |
| if Bottom = System.Null_Address then |
| Succeeded := False; |
| return; |
| end if; |
| |
| T.Common.LL.Uses_Fp := 1; |
| |
| -- This field has to be reset to 1 if T uses FP unit. But, without |
| -- a library-level procedure provided by this package, it cannot |
| -- be set easily. So temporarily, set it to 1 (which means all the |
| -- tasks will use FP unit. ??? |
| |
| T.Common.LL.Magic := RT_TASK_MAGIC; |
| T.Common.LL.State := RT_TASK_READY; |
| T.Common.LL.Succ := To_Address (T); |
| T.Common.LL.Pred := To_Address (T); |
| T.Common.LL.Active_Priority := Priority; |
| T.Common.Current_Priority := Priority; |
| |
| T.Common.LL.Stack_Bottom := Bottom; |
| T.Common.LL.Stack := Bottom + Storage_Offset (Adjusted_Stack_Size); |
| |
| -- Store the value T into the stack, so that Task_wrapper (defined |
| -- in System.Tasking.Stages) will find that value for its parameter |
| -- Self_ID, when the scheduler eventually transfers control to the |
| -- new task. |
| |
| T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes; |
| To_Address_Ptr (T.Common.LL.Stack).all := To_Address (T); |
| |
| -- Leave space for the return address, which will not be used, |
| -- since the task wrapper should never return. |
| |
| T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes; |
| To_Address_Ptr (T.Common.LL.Stack).all := System.Null_Address; |
| |
| -- Put the entry point address of the task wrapper |
| -- procedure on the new top of the stack. |
| |
| T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes; |
| To_Address_Ptr (T.Common.LL.Stack).all := Wrapper; |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| Insert_R (T); |
| R_Restore_Flags (Flags); |
| end Create_Task; |
| |
| ------------------ |
| -- Finalize_TCB -- |
| ------------------ |
| |
| procedure Finalize_TCB (T : Task_ID) is |
| begin |
| pragma Debug (Printk ("procedure Finalize_TCB called" & LF)); |
| |
| pragma Assert (T.Common.LL.Succ = To_Address (T)); |
| |
| if T.Common.LL.State = RT_TASK_DORMANT then |
| Known_Tasks (T.Known_Tasks_Index) := null; |
| T.Common.LL.Next := To_Address (Available_TCBs); |
| Available_TCBs := T; |
| Kfree (T.Common.LL.Stack_Bottom); |
| end if; |
| end Finalize_TCB; |
| |
| --------------- |
| -- Exit_Task -- |
| --------------- |
| |
| procedure Exit_Task is |
| Flags : Integer; |
| begin |
| pragma Debug (Printk ("procedure Exit_Task called" & LF)); |
| pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address)); |
| pragma Assert (Current_Task /= Environment_Task_ID); |
| |
| R_Save_Flags (Flags); |
| R_Cli; |
| Current_Task.Common.LL.State := RT_TASK_DORMANT; |
| Current_Task.Common.LL.Magic := 0; |
| Delete_R (Current_Task); |
| R_Restore_Flags (Flags); |
| Rt_Schedule; |
| end Exit_Task; |
| |
| ---------------- |
| -- Abort_Task -- |
| ---------------- |
| |
| -- ??? Not implemented for now |
| |
| procedure Abort_Task (T : Task_ID) is |
| -- Should cause T to raise Abort_Signal the next time it |
| -- executes. |
| -- ??? Can this ever be called when T = Current_Task? |
| -- To be safe, do nothing in this case. |
| begin |
| pragma Debug (Printk ("procedure Abort_Task called" & LF)); |
| null; |
| end Abort_Task; |
| |
| ---------------- |
| -- Check_Exit -- |
| ---------------- |
| |
| -- Dummy versions. The only currently working versions is for solaris |
| -- (native). |
| -- We should probably copy the working versions over from the Solaris |
| -- version of this package, with any appropriate changes, since without |
| -- the checks on it will probably be nearly impossible to debug the |
| -- run-time system. |
| |
| -- Not implemented for now |
| |
| function Check_Exit (Self_ID : Task_ID) return Boolean is |
| begin |
| pragma Debug (Printk ("function Check_Exit called" & LF)); |
| |
| return True; |
| end Check_Exit; |
| |
| -------------------- |
| -- Check_No_Locks -- |
| -------------------- |
| |
| function Check_No_Locks (Self_ID : Task_ID) return Boolean is |
| begin |
| pragma Debug (Printk ("function Check_No_Locks called" & LF)); |
| |
| if Self_ID.Common.LL.Outer_Lock = null then |
| return True; |
| else |
| return False; |
| end if; |
| end Check_No_Locks; |
| |
| ---------------------- |
| -- Environment_Task -- |
| ---------------------- |
| |
| function Environment_Task return Task_ID is |
| begin |
| return Environment_Task_ID; |
| end Environment_Task; |
| |
| ------------------------- |
| -- Lock_All_Tasks_List -- |
| ------------------------- |
| |
| procedure Lock_All_Tasks_List is |
| begin |
| pragma Debug (Printk ("procedure Lock_All_Tasks_List called" & LF)); |
| |
| Write_Lock (All_Tasks_L'Access); |
| end Lock_All_Tasks_List; |
| |
| --------------------------- |
| -- Unlock_All_Tasks_List -- |
| --------------------------- |
| |
| procedure Unlock_All_Tasks_List is |
| begin |
| pragma Debug (Printk ("procedure Unlock_All_Tasks_List called" & LF)); |
| |
| Unlock (All_Tasks_L'Access); |
| end Unlock_All_Tasks_List; |
| |
| ----------------- |
| -- Stack_Guard -- |
| ----------------- |
| |
| -- Not implemented for now |
| |
| procedure Stack_Guard (T : Task_ID; On : Boolean) is |
| begin |
| null; |
| end Stack_Guard; |
| |
| -------------------- |
| -- Get_Thread_Id -- |
| -------------------- |
| |
| function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is |
| begin |
| return To_Address (T); |
| end Get_Thread_Id; |
| |
| ------------------ |
| -- Suspend_Task -- |
| ------------------ |
| |
| function Suspend_Task |
| (T : Task_ID; |
| Thread_Self : OSI.Thread_Id) return Boolean is |
| begin |
| return False; |
| end Suspend_Task; |
| |
| ----------------- |
| -- Resume_Task -- |
| ----------------- |
| |
| function Resume_Task |
| (T : ST.Task_ID; |
| Thread_Self : OSI.Thread_Id) return Boolean is |
| begin |
| return False; |
| end Resume_Task; |
| |
| ----------------- |
| -- Init_Module -- |
| ----------------- |
| |
| function Init_Module return Integer is |
| procedure adainit; |
| pragma Import (C, adainit); |
| |
| begin |
| adainit; |
| In_Elab_Code := False; |
| Set_Priority (Environment_Task_ID, Any_Priority'First); |
| return 0; |
| end Init_Module; |
| |
| -------------------- |
| -- Cleanup_Module -- |
| -------------------- |
| |
| procedure Cleanup_Module is |
| procedure adafinal; |
| pragma Import (C, adafinal); |
| |
| begin |
| adafinal; |
| end Cleanup_Module; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| -- The environment task is "special". The TCB of the environment task is |
| -- not in the TCB_Array above. Logically, all initialization code for the |
| -- runtime system is executed by the environment task, but until the |
| -- environment task has initialized its own TCB we dare not execute any |
| -- calls that try to access the TCB of Current_Task. It is allocated by |
| -- target-independent runtime system code, in System.Tasking.Initializa- |
| -- tion.Init_RTS, before the call to this procedure Initialize. The |
| -- target-independent runtime system initializes all the components that |
| -- are target-independent, but this package needs to be given a chance to |
| -- initialize the target-dependent data. We do that in this procedure. |
| |
| -- In the present implementation, Environment_Task is set to be the |
| -- regular GNU/Linux kernel task. |
| |
| procedure Initialize (Environment_Task : Task_ID) is |
| begin |
| pragma Debug (Printk ("procedure Initialize called" & LF)); |
| |
| Environment_Task_ID := Environment_Task; |
| |
| -- Build the list of available ATCB's. |
| |
| Available_TCBs := To_Task_ID (TCB_Array (1)'Address); |
| |
| for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop |
| -- Note that the zeroth element in TCB_Array is not used, see |
| -- comments following the declaration of TCB_Array |
| |
| TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address; |
| end loop; |
| |
| TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address; |
| |
| -- Initialize the idle task, which is the head of Ready_Queue. |
| |
| Idle_Task.Common.LL.Magic := RT_TASK_MAGIC; |
| Idle_Task.Common.LL.State := RT_TASK_READY; |
| Idle_Task.Common.Current_Priority := System.Any_Priority'First; |
| Idle_Task.Common.LL.Active_Priority := System.Any_Priority'First; |
| Idle_Task.Common.LL.Succ := Idle_Task'Address; |
| Idle_Task.Common.LL.Pred := Idle_Task'Address; |
| |
| -- Initialize the regular GNU/Linux kernel task. |
| |
| Environment_Task.Common.LL.Magic := RT_TASK_MAGIC; |
| Environment_Task.Common.LL.State := RT_TASK_READY; |
| Environment_Task.Common.Current_Priority := System.Any_Priority'First; |
| Environment_Task.Common.LL.Active_Priority := System.Any_Priority'First; |
| Environment_Task.Common.LL.Succ := To_Address (Environment_Task); |
| Environment_Task.Common.LL.Pred := To_Address (Environment_Task); |
| |
| -- Initialize the head of Timer_Queue |
| |
| Timer_Queue.Common.LL.Succ := Timer_Queue'Address; |
| Timer_Queue.Common.LL.Pred := Timer_Queue'Address; |
| Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay; |
| |
| -- Set the current task to regular GNU/Linux kernel task |
| |
| Current_Task := Environment_Task; |
| |
| -- Set Timer_Wrapper to be the timer handler |
| |
| Rt_Free_Timer; |
| Rt_Request_Timer (Timer_Wrapper'Address); |
| |
| -- Initialize the lock used to synchronize chain of all ATCBs. |
| |
| Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); |
| |
| Enter_Task (Environment_Task); |
| end Initialize; |
| |
| end System.Task_Primitives.Operations; |
