diff options
Diffstat (limited to 'gcc/ada/5qtaprop.adb')
| -rw-r--r-- | gcc/ada/5qtaprop.adb | 1777 |
1 files changed, 1777 insertions, 0 deletions
diff --git a/gcc/ada/5qtaprop.adb b/gcc/ada/5qtaprop.adb new file mode 100644 index 00000000000..00cfe90c07f --- /dev/null +++ b/gcc/ada/5qtaprop.adb @@ -0,0 +1,1777 @@ +------------------------------------------------------------------------------ +-- -- +-- 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: 1.10 $ +-- -- +-- 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 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 Linux specific Data -- + ---------------------------- + + -- Define two important parameters necessary for a 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 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 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. + + Linux_Irq_State : Integer := 0; + + 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 + -- Linux kernel, and allow the regular Linux interrupt + -- handlers to preempt the current task again. + + if not In_Elab_Code then + SFIF := 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 Linux kernel to + -- execute an RT task, so don't allow the regular Linux + -- interrupt handlers to preempt the current task any more. + + 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 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 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 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; |