gcc/ada/5qtaprop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2001, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University. It is --
  30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  RT GNU/Linux version
  35
  36 --  ???? Later, look at what we might want to provide for interrupt
  37 --  management.
  38
  39 pragma Suppress (All_Checks);
  40
  41 pragma Polling (Off);
  42 --  Turn off polling, we do not want ATC polling to take place during
  43 --  tasking operations. It causes infinite loops and other problems.
  44
  45 with System.Machine_Code;
  46 --  used for Asm
  47
  48 with System.OS_Interface;
  49 --  used for various types, constants, and operations
  50
  51 with System.OS_Primitives;
  52 --  used for Delay_Modes
  53
  54 with System.Parameters;
  55 --  used for Size_Type
  56
  57 with System.Storage_Elements;
  58
  59 with System.Tasking;
  60 --  used for Ada_Task_Control_Block
  61 --           Task_ID
  62
  63 with Ada.Unchecked_Conversion;
  64
  65 package body System.Task_Primitives.Operations is
  66
  67    use System.Machine_Code,
  68        System.OS_Interface,
  69        System.OS_Primitives,
  70        System.Parameters,
  71        System.Tasking,
  72        System.Storage_Elements;
  73
  74    --------------------------------
  75    -- RT GNU/Linux specific Data --
  76    --------------------------------
  77
  78    --  Define two important parameters necessary for a GNU/Linux kernel module.
  79    --  Any module that is going to be loaded into the kernel space needs these
  80    --  parameters.
  81
  82    Mod_Use_Count : Integer;
  83    pragma Export (C, Mod_Use_Count, "mod_use_count_");
  84    --  for module usage tracking by the kernel
  85
  86    type Aliased_String is array (Positive range <>) of aliased Character;
  87    pragma Convention (C, Aliased_String);
  88
  89    Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul;
  90    pragma Export (C, Kernel_Version, "kernel_version");
  91    --  So that insmod can find the version number.
  92
  93    --  The following procedures have their name specified by the GNU/Linux
  94    --  module loader. Note that they simply correspond to adainit/adafinal.
  95
  96    function Init_Module return Integer;
  97    pragma Export (C, Init_Module, "init_module");
  98
  99    procedure Cleanup_Module;
 100    pragma Export (C, Cleanup_Module, "cleanup_module");
 101
 102    ----------------
 103    -- Local Data --
 104    ----------------
 105
 106    LF   : constant String := ASCII.LF & ASCII.Nul;
 107
 108    LFHT : constant String := ASCII.LF & ASCII.HT;
 109    --  used in inserted assembly code
 110
 111    Max_Tasks : constant := 10;
 112    --  ??? Eventually, this should probably be in System.Parameters.
 113
 114    Known_Tasks : array (0 .. Max_Tasks) of Task_ID;
 115    --  Global array of tasks read by gdb, and updated by Create_Task and
 116    --  Finalize_TCB. It's from System.Tasking.Debug. We moved it here to
 117    --  cut the dependence on that package. Consider moving it here or to
 118    --  this package specification, permanently????
 119
 120    Max_Sensible_Delay : constant RTIME :=
 121      365 * 24 * 60 * 60 * RT_TICKS_PER_SEC;
 122    --  Max of one year delay, needed to prevent exceptions for large
 123    --  delay values. It seems unlikely that any test will notice this
 124    --  restriction.
 125    --  ??? This is really declared in System.OS_Primitives,
 126    --  and the type is Duration, here its type is RTIME.
 127
 128    Tick_Count : constant := RT_TICKS_PER_SEC / 20;
 129    Nano_Count : constant := 50_000_000;
 130    --  two constants used in conversions between RTIME and Duration.
 131
 132    Addr_Bytes : constant Storage_Offset :=
 133      System.Address'Max_Size_In_Storage_Elements;
 134    --  number of bytes needed for storing an address.
 135
 136    Guess : constant RTIME := 10;
 137    --  an approximate amount of RTIME used in scheduler to awake a task having
 138    --  its resume time within 'current time + Guess'
 139    --  The value of 10 is estimated here and may need further refinement
 140
 141    TCB_Array : array (0 .. Max_Tasks)
 142      of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
 143    pragma Volatile_Components (TCB_Array);
 144
 145    Available_TCBs : Task_ID;
 146    pragma Atomic (Available_TCBs);
 147    --  Head of linear linked list of available TCB's, linked using TCB's
 148    --  LL.Next. This list is Initialized to contain a fixed number of tasks,
 149    --  when the runtime system starts up.
 150
 151    Current_Task : Task_ID;
 152    pragma Export (C, Current_Task, "current_task");
 153    pragma Atomic (Current_Task);
 154    --  This is the task currently running. We need the pragma here to specify
 155    --  the link-name for Current_Task is "current_task", rather than the long
 156    --  name (including the package name) that the Ada compiler would normally
 157    --  generate. "current_task" is referenced in procedure Rt_Switch_To below
 158
 159    Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
 160    --  Tail of the circular queue of ready to run tasks.
 161
 162    Scheduler_Idle : Boolean := False;
 163    --  True when the scheduler is idle (no task other than the idle task
 164    --  is on the ready queue).
 165
 166    In_Elab_Code : Boolean := True;
 167    --  True when we are elaborating our application.
 168    --  Init_Module will set this flag to false and never revert it.
 169
 170    Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
 171    --  Header of the queue of delayed real-time tasks.
 172    --  Timer_Queue.LL has to be initialized properly before being used
 173
 174    Timer_Expired : Boolean := False;
 175    --  flag to show whether the Timer_Queue needs to be checked
 176    --  when it becomes true, it means there is a task in the
 177    --  Timer_Queue having to be awakened and be moved to ready queue
 178
 179    Environment_Task_ID : Task_ID;
 180    --  A variable to hold Task_ID for the environment task.
 181    --  Once initialized, this behaves as a constant.
 182    --  In the current implementation, this is the task assigned permanently
 183    --  as the regular GNU/Linux kernel.
 184
 185    Single_RTS_Lock : aliased RTS_Lock;
 186    --  This is a lock to allow only one thread of control in the RTS at
 187    --  a time; it is used to execute in mutual exclusion from all other tasks.
 188    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 189
 190    --  The followings are internal configuration constants needed.
 191    Next_Serial_Number : Task_Serial_Number := 100;
 192    pragma Volatile (Next_Serial_Number);
 193    --  We start at 100, to reserve some special values for
 194    --  using in error checking.
 195
 196    GNU_Linux_Irq_State : Integer := 0;
 197    --  This needs comments ???
 198
 199    type Duration_As_Integer is delta 1.0
 200       range -2.0**(Duration'Size - 1) .. 2.0**(Duration'Size - 1) - 1.0;
 201    --  used for output RTIME value during debugging
 202
 203    type Address_Ptr is access all System.Address;
 204    pragma Convention (C, Address_Ptr);
 205
 206    --------------------------------
 207    -- Local conversion functions --
 208    --------------------------------
 209
 210    function To_Task_ID is new
 211      Ada.Unchecked_Conversion (System.Address, Task_ID);
 212
 213    function To_Address is new
 214      Ada.Unchecked_Conversion (Task_ID, System.Address);
 215
 216    function RTIME_To_D_Int is new
 217      Ada.Unchecked_Conversion (RTIME, Duration_As_Integer);
 218
 219    function Raw_RTIME is new
 220      Ada.Unchecked_Conversion (Duration, RTIME);
 221
 222    function Raw_Duration is new
 223      Ada.Unchecked_Conversion (RTIME, Duration);
 224
 225    function To_Duration (T : RTIME) return Duration;
 226    pragma Inline (To_Duration);
 227
 228    function To_RTIME (D : Duration) return RTIME;
 229    pragma Inline (To_RTIME);
 230
 231    function To_Integer is new
 232      Ada.Unchecked_Conversion (System.Parameters.Size_Type, Integer);
 233
 234    function To_Address_Ptr is
 235      new Ada.Unchecked_Conversion (System.Address, Address_Ptr);
 236
 237    function To_RTS_Lock_Ptr is new
 238      Ada.Unchecked_Conversion (Lock_Ptr, RTS_Lock_Ptr);
 239
 240    -----------------------------------
 241    -- Local Subprogram Declarations --
 242    -----------------------------------
 243
 244    procedure Rt_Switch_To (Tsk : Task_ID);
 245    pragma Inline (Rt_Switch_To);
 246    --  switch from the 'current_task' to 'Tsk'
 247    --  and 'Tsk' then becomes 'current_task'
 248
 249    procedure R_Save_Flags (F : out Integer);
 250    pragma Inline (R_Save_Flags);
 251    --  save EFLAGS register to 'F'
 252
 253    procedure R_Restore_Flags (F : Integer);
 254    pragma Inline (R_Restore_Flags);
 255    --  restore EFLAGS register from 'F'
 256
 257    procedure R_Cli;
 258    pragma Inline (R_Cli);
 259    --  disable interrupts
 260
 261    procedure R_Sti;
 262    pragma Inline (R_Sti);
 263    --  enable interrupts
 264
 265    procedure Timer_Wrapper;
 266    --  the timer handler. It sets Timer_Expired flag to True and
 267    --  then calls Rt_Schedule
 268
 269    procedure Rt_Schedule;
 270    --  the scheduler
 271
 272    procedure Insert_R (T : Task_ID);
 273    pragma Inline (Insert_R);
 274    --  insert 'T' into the tail of the ready queue for its active
 275    --  priority
 276    --  if original queue is 6 5 4 4 3 2 and T has priority of 4
 277    --  then after T is inserted the queue becomes 6 5 4 4 T 3 2
 278
 279    procedure Insert_RF (T : Task_ID);
 280    pragma Inline (Insert_RF);
 281    --  insert 'T' into the front of the ready queue for its active
 282    --  priority
 283    --  if original queue is 6 5 4 4 3 2 and T has priority of 4
 284    --  then after T is inserted the queue becomes 6 5 T 4 4 3 2
 285
 286    procedure Delete_R (T : Task_ID);
 287    pragma Inline (Delete_R);
 288    --  delete 'T' from the ready queue. If 'T' is not in any queue
 289    --  the operation has no effect
 290
 291    procedure Insert_T (T : Task_ID);
 292    pragma Inline (Insert_T);
 293    --  insert 'T' into the waiting queue according to its Resume_Time.
 294    --  If there are tasks in the waiting queue that have the same
 295    --  Resume_Time as 'T', 'T' is then inserted into the queue for
 296    --  its active priority
 297
 298    procedure Delete_T (T : Task_ID);
 299    pragma Inline (Delete_T);
 300    --  delete 'T' from the waiting queue.
 301
 302    procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
 303    pragma Inline (Move_Top_Task_From_Timer_Queue_To_Ready_Queue);
 304    --  remove the task in the front of the waiting queue and insert it
 305    --  into the tail of the ready queue for its active priority
 306
 307    -------------------------
 308    --  Local Subprograms  --
 309    -------------------------
 310
 311    procedure Rt_Switch_To (Tsk : Task_ID) is
 312    begin
 313       pragma Debug (Printk ("procedure Rt_Switch_To called" & LF));
 314
 315       Asm (
 316         "pushl %%eax" & LFHT &
 317         "pushl %%ebp" & LFHT &
 318         "pushl %%edi" & LFHT &
 319         "pushl %%esi" & LFHT &
 320         "pushl %%edx" & LFHT &
 321         "pushl %%ecx" & LFHT &
 322         "pushl %%ebx" & LFHT &
 323
 324         "movl current_task, %%edx" & LFHT &
 325         "cmpl $0, 36(%%edx)" & LFHT &
 326          --  36 is hard-coded, 36(%%edx) is actually
 327          --  Current_Task.Common.LL.Uses_Fp
 328
 329         "jz 25f" & LFHT &
 330         "sub $108,%%esp" & LFHT &
 331         "fsave (%%esp)" & LFHT &
 332         "25:      pushl $1f" & LFHT &
 333         "movl %%esp, 32(%%edx)" & LFHT &
 334          --  32 is hard-coded, 32(%%edx) is actually
 335          --  Current_Task.Common.LL.Stack
 336
 337         "movl 32(%%ecx), %%esp" & LFHT &
 338          --  32 is hard-coded, 32(%%ecx) is actually Tsk.Common.LL.Stack.
 339          --  Tsk is the task to be switched to
 340
 341         "movl %%ecx, current_task" & LFHT &
 342         "ret" & LFHT &
 343         "1:       cmpl $0, 36(%%ecx)" & LFHT &
 344          --  36(%%exc) is Tsk.Common.LL.Stack (hard coded)
 345         "jz 26f" & LFHT &
 346         "frstor (%%esp)" & LFHT &
 347         "add $108,%%esp" & LFHT &
 348         "26:      popl %%ebx" & LFHT &
 349         "popl %%ecx" & LFHT &
 350         "popl %%edx" & LFHT &
 351         "popl %%esi" & LFHT &
 352         "popl %%edi" & LFHT &
 353         "popl %%ebp" & LFHT &
 354         "popl %%eax",
 355         Outputs  => No_Output_Operands,
 356         Inputs   => Task_ID'Asm_Input ("c", Tsk),
 357         Clobber  => "cx",
 358         Volatile => True);
 359    end Rt_Switch_To;
 360
 361    procedure R_Save_Flags (F : out Integer) is
 362    begin
 363       Asm (
 364         "pushfl" & LFHT &
 365         "popl %0",
 366         Outputs  => Integer'Asm_Output ("=g", F),
 367         Inputs   => No_Input_Operands,
 368         Clobber  => "memory",
 369         Volatile => True);
 370    end R_Save_Flags;
 371
 372    procedure R_Restore_Flags (F : Integer) is
 373    begin
 374       Asm (
 375         "pushl %0" & LFHT &
 376         "popfl",
 377         Outputs  => No_Output_Operands,
 378         Inputs   => Integer'Asm_Input ("g", F),
 379         Clobber  => "memory",
 380         Volatile => True);
 381    end R_Restore_Flags;
 382
 383    procedure R_Sti is
 384    begin
 385       Asm (
 386          "sti",
 387          Outputs  => No_Output_Operands,
 388          Inputs   => No_Input_Operands,
 389          Clobber  => "memory",
 390          Volatile => True);
 391    end R_Sti;
 392
 393    procedure R_Cli is
 394    begin
 395       Asm (
 396         "cli",
 397         Outputs  => No_Output_Operands,
 398         Inputs   => No_Input_Operands,
 399         Clobber  => "memory",
 400         Volatile => True);
 401    end R_Cli;
 402
 403    --  A wrapper for Rt_Schedule, works as the timer handler
 404
 405    procedure Timer_Wrapper is
 406    begin
 407       pragma Debug (Printk ("procedure Timer_Wrapper called" & LF));
 408
 409       Timer_Expired := True;
 410       Rt_Schedule;
 411    end Timer_Wrapper;
 412
 413    procedure Rt_Schedule is
 414       Now      : RTIME;
 415       Top_Task : Task_ID;
 416       Flags    : Integer;
 417
 418       procedure Debug_Timer_Queue;
 419       --  Check the state of the Timer Queue.
 420
 421       procedure Debug_Timer_Queue is
 422       begin
 423          if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
 424             Printk ("Timer_Queue not empty" & LF);
 425          end if;
 426
 427          if To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time <
 428            Now + Guess
 429          then
 430             Printk ("and need to move top task to ready queue" & LF);
 431          end if;
 432       end Debug_Timer_Queue;
 433
 434    begin
 435       pragma Debug (Printk ("procedure Rt_Schedule called" & LF));
 436
 437       --  Scheduler_Idle means that this call comes from an interrupt
 438       --  handler (e.g timer) that interrupted the idle loop below.
 439
 440       if Scheduler_Idle then
 441          return;
 442       end if;
 443
 444       <<Idle>>
 445       R_Save_Flags (Flags);
 446       R_Cli;
 447
 448       Scheduler_Idle := False;
 449
 450       if Timer_Expired then
 451          pragma Debug (Printk ("Timer expired" & LF));
 452          Timer_Expired := False;
 453
 454          --  Check for expired time delays.
 455          Now := Rt_Get_Time;
 456
 457          --  Need another (circular) queue for delayed tasks, this one ordered
 458          --  by wakeup time, so the one at the front has the earliest resume
 459          --  time. Wake up all the tasks sleeping on time delays that should
 460          --  be awakened at this time.
 461
 462          --  ??? This is not very good, since we may waste time here waking
 463          --  up a bunch of lower priority tasks, adding to the blocking time
 464          --  of higher priority ready tasks, but we don't see how to get
 465          --  around this without adding more wasted time elsewhere.
 466
 467          pragma Debug (Debug_Timer_Queue);
 468
 469          while Timer_Queue.Common.LL.Succ /= Timer_Queue'Address and then
 470            To_Task_ID
 471              (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < Now + Guess
 472          loop
 473             To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.State :=
 474               RT_TASK_READY;
 475             Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
 476          end loop;
 477
 478          --  Arm the timer if necessary.
 479          --  ??? This may be wasteful, if the tasks on the timer queue are
 480          --  of lower priority than the current task's priority. The problem
 481          --  is that we can't tell this without scanning the whole timer
 482          --  queue. This scanning takes extra time.
 483
 484          if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
 485             --  Timer_Queue is not empty, so set the timer to interrupt at
 486             --  the next resume time. The Wakeup procedure must also do this,
 487             --  and must do it while interrupts are disabled so that there is
 488             --  no danger of interleaving with this code.
 489             Rt_Set_Timer
 490               (To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time);
 491          else
 492             Rt_No_Timer;
 493          end if;
 494       end if;
 495
 496       Top_Task := To_Task_ID (Idle_Task.Common.LL.Succ);
 497
 498       --  If the ready queue is empty, the kernel has to wait until the timer
 499       --  or another interrupt makes a task ready.
 500
 501       if Top_Task = To_Task_ID (Idle_Task'Address) then
 502          Scheduler_Idle := True;
 503          R_Restore_Flags (Flags);
 504          pragma Debug (Printk ("!!!kernel idle!!!" & LF));
 505          goto Idle;
 506       end if;
 507
 508       if Top_Task = Current_Task then
 509          pragma Debug (Printk ("Rt_Schedule: Top_Task = Current_Task" & LF));
 510          --  if current task continues, just return.
 511
 512          R_Restore_Flags (Flags);
 513          return;
 514       end if;
 515
 516       if Top_Task = Environment_Task_ID then
 517          pragma Debug (Printk
 518            ("Rt_Schedule: Top_Task = Environment_Task" & LF));
 519          --  If there are no RT tasks ready, we execute the regular
 520          --  GNU/Linux kernel, and allow the regular GNU/Linux interrupt
 521          --  handlers to preempt the current task again.
 522
 523          if not In_Elab_Code then
 524             SFIF := GNU_Linux_Irq_State;
 525          end if;
 526
 527       elsif Current_Task = Environment_Task_ID then
 528          pragma Debug (Printk
 529            ("Rt_Schedule: Current_Task = Environment_Task" & LF));
 530          --  We are going to preempt the regular GNU/Linux kernel to
 531          --  execute an RT task, so don't allow the regular GNU/Linux
 532          --  interrupt handlers to preempt the current task any more.
 533
 534          GNU_Linux_Irq_State := SFIF;
 535          SFIF := 0;
 536       end if;
 537
 538       Top_Task.Common.LL.State := RT_TASK_READY;
 539       Rt_Switch_To (Top_Task);
 540       R_Restore_Flags (Flags);
 541    end Rt_Schedule;
 542
 543    procedure Insert_R (T : Task_ID) is
 544       Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
 545    begin
 546       pragma Debug (Printk ("procedure Insert_R called" & LF));
 547
 548       pragma Assert (T.Common.LL.Succ = To_Address (T));
 549       pragma Assert (T.Common.LL.Pred = To_Address (T));
 550
 551       --  T is inserted in the queue between a task that has higher
 552       --  or the same Active_Priority as T and a task that has lower
 553       --  Active_Priority than T
 554
 555       while Q /= To_Task_ID (Idle_Task'Address)
 556         and then T.Common.LL.Active_Priority <= Q.Common.LL.Active_Priority
 557       loop
 558          Q := To_Task_ID (Q.Common.LL.Succ);
 559       end loop;
 560
 561       --  Q is successor of T
 562
 563       T.Common.LL.Succ := To_Address (Q);
 564       T.Common.LL.Pred := Q.Common.LL.Pred;
 565       To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
 566       Q.Common.LL.Pred := To_Address (T);
 567    end Insert_R;
 568
 569    procedure Insert_RF (T : Task_ID) is
 570       Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
 571    begin
 572       pragma Debug (Printk ("procedure Insert_RF called" & LF));
 573
 574       pragma Assert (T.Common.LL.Succ = To_Address (T));
 575       pragma Assert (T.Common.LL.Pred = To_Address (T));
 576
 577       --  T is inserted in the queue between a task that has higher
 578       --  Active_Priority as T and a task that has lower or the same
 579       --  Active_Priority as T
 580
 581       while Q /= To_Task_ID (Idle_Task'Address) and then
 582         T.Common.LL.Active_Priority < Q.Common.LL.Active_Priority
 583       loop
 584          Q := To_Task_ID (Q.Common.LL.Succ);
 585       end loop;
 586
 587       --  Q is successor of T
 588
 589       T.Common.LL.Succ := To_Address (Q);
 590       T.Common.LL.Pred := Q.Common.LL.Pred;
 591       To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
 592       Q.Common.LL.Pred := To_Address (T);
 593    end Insert_RF;
 594
 595    procedure Delete_R (T : Task_ID) is
 596       Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
 597       Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
 598
 599    begin
 600       pragma Debug (Printk ("procedure Delete_R called" & LF));
 601
 602       --  checking whether T is in the queue is not necessary because
 603       --  if T is not in the queue, following statements changes
 604       --  nothing. But T cannot be in the Timer_Queue, otherwise
 605       --  activate the check below, note that checking whether T is
 606       --  in a queue is a relatively expensive operation
 607
 608       Tpred.Common.LL.Succ := To_Address (Tsucc);
 609       Tsucc.Common.LL.Pred := To_Address (Tpred);
 610       T.Common.LL.Succ := To_Address (T);
 611       T.Common.LL.Pred := To_Address (T);
 612    end Delete_R;
 613
 614    procedure Insert_T (T : Task_ID) is
 615       Q : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
 616    begin
 617       pragma Debug (Printk ("procedure Insert_T called" & LF));
 618
 619       pragma Assert (T.Common.LL.Succ = To_Address (T));
 620
 621       while Q /= To_Task_ID (Timer_Queue'Address) and then
 622         T.Common.LL.Resume_Time > Q.Common.LL.Resume_Time
 623       loop
 624          Q := To_Task_ID (Q.Common.LL.Succ);
 625       end loop;
 626
 627       --  Q is the task that has Resume_Time equal to or greater than that
 628       --  of T. If they have the same Resume_Time, continue looking for the
 629       --  location T is to be inserted using its Active_Priority
 630
 631       while Q /= To_Task_ID (Timer_Queue'Address) and then
 632         T.Common.LL.Resume_Time = Q.Common.LL.Resume_Time
 633       loop
 634          exit when T.Common.LL.Active_Priority > Q.Common.LL.Active_Priority;
 635          Q := To_Task_ID (Q.Common.LL.Succ);
 636       end loop;
 637
 638       --  Q is successor of T
 639
 640       T.Common.LL.Succ := To_Address (Q);
 641       T.Common.LL.Pred := Q.Common.LL.Pred;
 642       To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
 643       Q.Common.LL.Pred := To_Address (T);
 644    end Insert_T;
 645
 646    procedure Delete_T (T : Task_ID) is
 647       Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
 648       Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
 649
 650    begin
 651       pragma Debug (Printk ("procedure Delete_T called" & LF));
 652
 653       pragma Assert (T /= To_Task_ID (Timer_Queue'Address));
 654
 655       Tpred.Common.LL.Succ := To_Address (Tsucc);
 656       Tsucc.Common.LL.Pred := To_Address (Tpred);
 657       T.Common.LL.Succ := To_Address (T);
 658       T.Common.LL.Pred := To_Address (T);
 659    end Delete_T;
 660
 661    procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue is
 662       Top_Task : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
 663    begin
 664       pragma Debug (Printk ("procedure Move_Top_Task called" & LF));
 665
 666       if Top_Task /= To_Task_ID (Timer_Queue'Address) then
 667          Delete_T (Top_Task);
 668          Top_Task.Common.LL.State := RT_TASK_READY;
 669          Insert_R (Top_Task);
 670       end if;
 671    end  Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
 672
 673    ----------
 674    -- Self --
 675    ----------
 676
 677    function Self return Task_ID is
 678    begin
 679       pragma Debug (Printk ("function Self called" & LF));
 680
 681       return Current_Task;
 682    end Self;
 683
 684    ---------------------
 685    -- Initialize_Lock --
 686    ---------------------
 687
 688    procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
 689    begin
 690       pragma Debug (Printk ("procedure Initialize_Lock called" & LF));
 691
 692       L.Ceiling_Priority := Prio;
 693       L.Owner := System.Null_Address;
 694    end Initialize_Lock;
 695
 696    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 697    begin
 698       pragma Debug (Printk ("procedure Initialize_Lock (RTS) called" & LF));
 699
 700       L.Ceiling_Priority := System.Any_Priority'Last;
 701       L.Owner := System.Null_Address;
 702    end Initialize_Lock;
 703
 704    -------------------
 705    -- Finalize_Lock --
 706    -------------------
 707
 708    procedure Finalize_Lock (L : access Lock) is
 709    begin
 710       pragma Debug (Printk ("procedure Finalize_Lock called" & LF));
 711       null;
 712    end Finalize_Lock;
 713
 714    procedure Finalize_Lock (L : access RTS_Lock) is
 715    begin
 716       pragma Debug (Printk ("procedure Finalize_Lock (RTS) called" & LF));
 717       null;
 718    end Finalize_Lock;
 719
 720    ----------------
 721    -- Write_Lock --
 722    ----------------
 723
 724    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 725       Prio : constant System.Any_Priority :=
 726         Current_Task.Common.LL.Active_Priority;
 727
 728    begin
 729       pragma Debug (Printk ("procedure Write_Lock called" & LF));
 730
 731       Ceiling_Violation := False;
 732
 733       if Prio > L.Ceiling_Priority then
 734          --  Ceiling violation.
 735          --  This should never happen, unless something is seriously
 736          --  wrong with task T or the entire run-time system.
 737          --  ???? extreme error recovery, e.g. shut down the system or task
 738
 739          Ceiling_Violation := True;
 740          pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF));
 741          return;
 742       end if;
 743
 744       L.Pre_Locking_Priority := Prio;
 745       L.Owner := To_Address (Current_Task);
 746       Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
 747
 748       if Current_Task.Common.LL.Outer_Lock = null then
 749          --  If this lock is not nested, record a pointer to it.
 750
 751          Current_Task.Common.LL.Outer_Lock :=
 752            To_RTS_Lock_Ptr (L.all'Unchecked_Access);
 753       end if;
 754    end Write_Lock;
 755
 756    procedure Write_Lock
 757      (L : access RTS_Lock; Global_Lock : Boolean := False)
 758    is
 759       Prio : constant System.Any_Priority :=
 760         Current_Task.Common.LL.Active_Priority;
 761
 762    begin
 763       pragma Debug (Printk ("procedure Write_Lock (RTS) called" & LF));
 764
 765       if Prio > L.Ceiling_Priority then
 766          --  Ceiling violation.
 767          --  This should never happen, unless something is seriously
 768          --  wrong with task T or the entire runtime system.
 769          --  ???? extreme error recovery, e.g. shut down the system or task
 770
 771          Printk ("Ceiling Violation in Write_Lock (RTS)" & LF);
 772          return;
 773       end if;
 774
 775       L.Pre_Locking_Priority := Prio;
 776       L.Owner := To_Address (Current_Task);
 777       Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
 778
 779       if Current_Task.Common.LL.Outer_Lock = null then
 780          Current_Task.Common.LL.Outer_Lock := L.all'Unchecked_Access;
 781       end if;
 782    end Write_Lock;
 783
 784    procedure Write_Lock (T : Task_ID) is
 785       Prio : constant System.Any_Priority :=
 786         Current_Task.Common.LL.Active_Priority;
 787
 788    begin
 789       pragma Debug (Printk ("procedure Write_Lock (Task_ID) called" & LF));
 790
 791       if Prio > T.Common.LL.L.Ceiling_Priority then
 792          --  Ceiling violation.
 793          --  This should never happen, unless something is seriously
 794          --  wrong with task T or the entire runtime system.
 795          --  ???? extreme error recovery, e.g. shut down the system or task
 796
 797          Printk ("Ceiling Violation in Write_Lock (Task)" & LF);
 798          return;
 799       end if;
 800
 801       T.Common.LL.L.Pre_Locking_Priority := Prio;
 802       T.Common.LL.L.Owner := To_Address (Current_Task);
 803       Current_Task.Common.LL.Active_Priority := T.Common.LL.L.Ceiling_Priority;
 804
 805       if Current_Task.Common.LL.Outer_Lock = null then
 806          Current_Task.Common.LL.Outer_Lock := T.Common.LL.L'Access;
 807       end if;
 808    end Write_Lock;
 809
 810    ---------------
 811    -- Read_Lock --
 812    ---------------
 813
 814    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 815    begin
 816       pragma Debug (Printk ("procedure Read_Lock called" & LF));
 817       Write_Lock (L, Ceiling_Violation);
 818    end Read_Lock;
 819
 820    ------------
 821    -- Unlock --
 822    ------------
 823
 824    procedure Unlock (L : access Lock) is
 825       Flags : Integer;
 826    begin
 827       pragma Debug (Printk ("procedure Unlock called" & LF));
 828
 829       if L.Owner /= To_Address (Current_Task) then
 830          --  ...error recovery
 831
 832          null;
 833          Printk ("The caller is not the owner of the lock" & LF);
 834          return;
 835       end if;
 836
 837       L.Owner := System.Null_Address;
 838
 839       --  Now that the lock is released, lower own priority,
 840
 841       if Current_Task.Common.LL.Outer_Lock =
 842         To_RTS_Lock_Ptr (L.all'Unchecked_Access)
 843       then
 844          --  This lock is the outer-most one, reset own priority to
 845          --  Current_Priority;
 846
 847          Current_Task.Common.LL.Active_Priority :=
 848            Current_Task.Common.Current_Priority;
 849          Current_Task.Common.LL.Outer_Lock := null;
 850
 851       else
 852          --  If this lock is nested, pop the old active priority.
 853
 854          Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
 855       end if;
 856
 857       --  Reschedule the task if necessary. Note we only need to reschedule
 858       --  the task if its Active_Priority becomes less than the one following
 859       --  it. The check depends on the fact that Environment_Task (tail of
 860       --  the ready queue) has the lowest Active_Priority
 861
 862       if Current_Task.Common.LL.Active_Priority
 863         < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
 864       then
 865          R_Save_Flags (Flags);
 866          R_Cli;
 867          Delete_R (Current_Task);
 868          Insert_RF (Current_Task);
 869          R_Restore_Flags (Flags);
 870          Rt_Schedule;
 871       end if;
 872    end Unlock;
 873
 874    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 875       Flags : Integer;
 876    begin
 877       pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF));
 878
 879       if L.Owner /= To_Address (Current_Task) then
 880          null;
 881          Printk ("The caller is not the owner of the lock" & LF);
 882          return;
 883       end if;
 884
 885       L.Owner := System.Null_Address;
 886
 887       if Current_Task.Common.LL.Outer_Lock = L.all'Unchecked_Access then
 888          Current_Task.Common.LL.Active_Priority :=
 889            Current_Task.Common.Current_Priority;
 890          Current_Task.Common.LL.Outer_Lock := null;
 891
 892       else
 893          Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
 894       end if;
 895
 896       --  Reschedule the task if necessary
 897
 898       if Current_Task.Common.LL.Active_Priority
 899         < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
 900       then
 901          R_Save_Flags (Flags);
 902          R_Cli;
 903          Delete_R (Current_Task);
 904          Insert_RF (Current_Task);
 905          R_Restore_Flags (Flags);
 906          Rt_Schedule;
 907       end if;
 908    end Unlock;
 909
 910    procedure Unlock (T : Task_ID) is
 911    begin
 912       pragma Debug (Printk ("procedure Unlock (Task_ID) called" & LF));
 913       Unlock (T.Common.LL.L'Access);
 914    end Unlock;
 915
 916    -----------
 917    -- Sleep --
 918    -----------
 919
 920    --  Unlock Self_ID.Common.LL.L and suspend Self_ID, atomically.
 921    --  Before return, lock Self_ID.Common.LL.L again
 922    --  Self_ID can only be reactivated by calling Wakeup.
 923    --  Unlock code is repeated intentionally.
 924
 925    procedure Sleep
 926      (Self_ID : Task_ID;
 927       Reason  : ST.Task_States)
 928    is
 929       Flags : Integer;
 930    begin
 931       pragma Debug (Printk ("procedure Sleep called" & LF));
 932
 933       --  Note that Self_ID is actually Current_Task, that is, only the
 934       --  task that is running can put itself into sleep. To preserve
 935       --  consistency, we use Self_ID throughout the code here
 936
 937       Self_ID.Common.State := Reason;
 938       Self_ID.Common.LL.State := RT_TASK_DORMANT;
 939
 940       R_Save_Flags (Flags);
 941       R_Cli;
 942
 943       Delete_R (Self_ID);
 944
 945       --  Arrange to unlock Self_ID's ATCB lock. The following check
 946       --  may be unnecessary because the specification of Sleep says
 947       --  the caller should hold its own ATCB lock before calling Sleep
 948
 949       if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
 950          Self_ID.Common.LL.L.Owner := System.Null_Address;
 951
 952          if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
 953             Self_ID.Common.LL.Active_Priority :=
 954               Self_ID.Common.Current_Priority;
 955             Self_ID.Common.LL.Outer_Lock := null;
 956
 957          else
 958             Self_ID.Common.LL.Active_Priority :=
 959               Self_ID.Common.LL.L.Pre_Locking_Priority;
 960          end if;
 961       end if;
 962
 963       R_Restore_Flags (Flags);
 964       Rt_Schedule;
 965
 966       --  Before leave, regain the lock
 967
 968       Write_Lock (Self_ID);
 969    end Sleep;
 970
 971    -----------------
 972    -- Timed_Sleep --
 973    -----------------
 974
 975    --  Arrange to be awakened after/at Time (depending on Mode) then Unlock
 976    --  Self_ID.Common.LL.L and suspend self. If the timeout expires first,
 977    --  that should awaken the task. If it's awakened (by some other task
 978    --  calling Wakeup) before the timeout expires, the timeout should be
 979    --  cancelled.
 980
 981    --  This is for use within the run-time system, so abort is
 982    --  assumed to be already deferred, and the caller should be
 983    --  holding its own ATCB lock.
 984
 985    procedure Timed_Sleep
 986      (Self_ID  : Task_ID;
 987       Time     : Duration;
 988       Mode     : ST.Delay_Modes;
 989       Reason   : Task_States;
 990       Timedout : out Boolean;
 991       Yielded  : out Boolean)
 992    is
 993       Flags      : Integer;
 994       Abs_Time   : RTIME;
 995
 996    begin
 997       pragma Debug (Printk ("procedure Timed_Sleep called" & LF));
 998
 999       Timedout := True;
1000       Yielded := False;
1001       --  ??? These two boolean seems not relevant here
1002
1003       if Mode = Relative then
1004          Abs_Time := To_RTIME (Time) + Rt_Get_Time;
1005       else
1006          Abs_Time := To_RTIME (Time);
1007       end if;
1008
1009       Self_ID.Common.LL.Resume_Time := Abs_Time;
1010       Self_ID.Common.LL.State := RT_TASK_DELAYED;
1011
1012       R_Save_Flags (Flags);
1013       R_Cli;
1014       Delete_R (Self_ID);
1015       Insert_T (Self_ID);
1016
1017       --  Check if the timer needs to be set
1018
1019       if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
1020          Rt_Set_Timer (Abs_Time);
1021       end if;
1022
1023       --  Another way to do it
1024       --
1025       --  if Abs_Time <
1026       --    To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time
1027       --  then
1028       --     Rt_Set_Timer (Abs_Time);
1029       --  end if;
1030
1031       --  Arrange to unlock Self_ID's ATCB lock. see comments in Sleep
1032
1033       if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
1034          Self_ID.Common.LL.L.Owner := System.Null_Address;
1035
1036          if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
1037             Self_ID.Common.LL.Active_Priority :=
1038               Self_ID.Common.Current_Priority;
1039             Self_ID.Common.LL.Outer_Lock := null;
1040
1041          else
1042             Self_ID.Common.LL.Active_Priority :=
1043               Self_ID.Common.LL.L.Pre_Locking_Priority;
1044          end if;
1045       end if;
1046
1047       R_Restore_Flags (Flags);
1048       Rt_Schedule;
1049
1050       --  Before leaving, regain the lock
1051
1052       Write_Lock (Self_ID);
1053    end Timed_Sleep;
1054
1055    -----------------
1056    -- Timed_Delay --
1057    -----------------
1058
1059    --  This is for use in implementing delay statements, so we assume
1060    --  the caller is not abort-deferred and is holding no locks.
1061    --  Self_ID can only be awakened after the timeout, no Wakeup on it.
1062
1063    procedure Timed_Delay
1064      (Self_ID  : Task_ID;
1065       Time     : Duration;
1066       Mode     : ST.Delay_Modes)
1067    is
1068       Flags      : Integer;
1069       Abs_Time   : RTIME;
1070
1071    begin
1072       pragma Debug (Printk ("procedure Timed_Delay called" & LF));
1073
1074       --  Only the little window between deferring abort and
1075       --  locking Self_ID is the reason we need to
1076       --  check for pending abort and priority change below! :(
1077
1078       Write_Lock (Self_ID);
1079
1080       --  Take the lock in case its ATCB needs to be modified
1081
1082       if Mode = Relative then
1083          Abs_Time := To_RTIME (Time) + Rt_Get_Time;
1084       else
1085          Abs_Time := To_RTIME (Time);
1086       end if;
1087
1088       Self_ID.Common.LL.Resume_Time := Abs_Time;
1089       Self_ID.Common.LL.State := RT_TASK_DELAYED;
1090
1091       R_Save_Flags (Flags);
1092       R_Cli;
1093       Delete_R (Self_ID);
1094       Insert_T (Self_ID);
1095
1096       --  Check if the timer needs to be set
1097
1098       if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
1099          Rt_Set_Timer (Abs_Time);
1100       end if;
1101
1102       --  Arrange to unlock Self_ID's ATCB lock.
1103       --  Note that the code below is slightly different from Unlock, so
1104       --  it is more than inline it.
1105
1106       if To_Task_ID (Self_ID.Common.LL.L.Owner) = Self_ID then
1107          Self_ID.Common.LL.L.Owner := System.Null_Address;
1108
1109          if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
1110             Self_ID.Common.LL.Active_Priority :=
1111               Self_ID.Common.Current_Priority;
1112             Self_ID.Common.LL.Outer_Lock := null;
1113
1114          else
1115             Self_ID.Common.LL.Active_Priority :=
1116               Self_ID.Common.LL.L.Pre_Locking_Priority;
1117          end if;
1118       end if;
1119
1120       R_Restore_Flags (Flags);
1121       Rt_Schedule;
1122    end Timed_Delay;
1123
1124    ---------------------
1125    -- Monotonic_Clock --
1126    ---------------------
1127
1128    --  RTIME is represented as a 64-bit signed count of ticks,
1129    --  where there are 1_193_180 ticks per second.
1130
1131    --  Let T be a count of ticks and N the corresponding count of nanoseconds.
1132    --  From the following relationship
1133    --    T / (ticks_per_second) = N / (ns_per_second)
1134    --  where ns_per_second is 1_000_000_000 (number of nanoseconds in
1135    --  a second), we get
1136    --    T * (ns_per_second) = N * (ticks_per_second)
1137    --  or
1138    --    T * 1_000_000_000   = N * 1_193_180
1139    --  which can be reduced to
1140    --    T * 50_000_000      = N * 59_659
1141    --  Let Nano_Count = 50_000_000 and Tick_Count = 59_659, we then have
1142    --    T * Nano_Count = N * Tick_Count
1143
1144    --  IMPORTANT FACT:
1145    --  These numbers are small enough that we can do arithmetic
1146    --  on them without overflowing 64 bits.  To see this, observe
1147
1148    --  10**3 = 1000 < 1024 = 2**10
1149    --  Tick_Count < 60 * 1000 < 64 * 1024 < 2**16
1150    --  Nano_Count < 50 * 1000 * 1000 < 64 * 1024 * 1024 < 2**26
1151
1152    --  It follows that if 0 <= R < Tick_Count, we can compute
1153    --  R * Nano_Count < 2**42 without overflow in 64 bits.
1154    --  Similarly, if 0 <= R < Nano_Count, we can compute
1155    --  R * Tick_Count < 2**42 without overflow in 64 bits.
1156
1157    --  GNAT represents Duration as a count of nanoseconds internally.
1158
1159    --  To convert T from RTIME to Duration, let
1160    --    Q = T / Tick_Count, with truncation
1161    --    R = T - Q * Tick_Count, the remainder 0 <= R < Tick_Count
1162    --  so
1163    --    N * Tick_Count
1164    --      =  T * Nano_Count - Q * Tick_Count * Nano_Count
1165    --         + Q * Tick_Count * Nano_Count
1166    --      = (T - Q * Tick_Count) * Nano_Count
1167    --         + (Q * Nano_Count) * Tick_Count
1168    --      =  R * Nano_Count + (Q * Nano_Count) * Tick_Count
1169
1170    --  Now, let
1171    --    Q1 = R * Nano_Count / Tick_Count, with truncation
1172    --    R1 = R * Nano_Count - Q1 * Tick_Count, 0 <= R1 <Tick_Count
1173    --    R * Nano_Count = Q1 * Tick_Count + R1
1174    --  so
1175    --    N * Tick_Count
1176    --      = R * Nano_Count + (Q * Nano_Count) * Tick_Count
1177    --      = Q1 * Tick_Count + R1 + (Q * Nano_Count) * Tick_Count
1178    --      = R1 + (Q * Nano_Count + Q1) * Tick_Count
1179    --  and
1180    --    N = Q * Nano_Count + Q1 + R1 /Tick_Count,
1181    --    where 0 <= R1 /Tick_Count < 1
1182
1183    function To_Duration (T : RTIME) return Duration is
1184       Q, Q1, RN : RTIME;
1185    begin
1186       Q  := T / Tick_Count;
1187       RN := (T - Q * Tick_Count) * Nano_Count;
1188       Q1 := RN / Tick_Count;
1189       return Raw_Duration (Q * Nano_Count + Q1);
1190    end To_Duration;
1191
1192    --  To convert D from Duration to RTIME,
1193    --  Let D be a Duration value, and N be the representation of D as an
1194    --  integer count of nanoseconds. Let
1195    --    Q = N / Nano_Count, with truncation
1196    --    R = N - Q * Nano_Count, the remainder 0 <= R < Nano_Count
1197    --  so
1198    --    T * Nano_Count
1199    --      = N * Tick_Count - Q * Nano_Count * Tick_Count
1200    --        + Q * Nano_Count * Tick_Count
1201    --      = (N - Q * Nano_Count) * Tick_Count
1202    --         + (Q * Tick_Count) * Nano_Count
1203    --      = R * Tick_Count + (Q * Tick_Count) * Nano_Count
1204    --  Now, let
1205    --    Q1 = R * Tick_Count / Nano_Count, with truncation
1206    --    R1 = R * Tick_Count - Q1 * Nano_Count, 0 <= R1 < Nano_Count
1207    --    R * Tick_Count = Q1 * Nano_Count + R1
1208    --  so
1209    --    T * Nano_Count
1210    --      = R * Tick_Count + (Q * Tick_Count) * Nano_Count
1211    --      = Q1 * Nano_Count + R1 + (Q * Tick_Count) * Nano_Count
1212    --      = (Q * Tick_Count + Q1) * Nano_Count + R1
1213    --  and
1214    --    T = Q * Tick_Count + Q1 + R1 / Nano_Count,
1215    --    where 0 <= R1 / Nano_Count < 1
1216
1217    function To_RTIME (D : Duration) return RTIME is
1218       N : RTIME := Raw_RTIME (D);
1219       Q, Q1, RT : RTIME;
1220
1221    begin
1222       Q  := N / Nano_Count;
1223       RT := (N - Q * Nano_Count) * Tick_Count;
1224       Q1 := RT / Nano_Count;
1225       return Q * Tick_Count + Q1;
1226    end To_RTIME;
1227
1228    function Monotonic_Clock return Duration is
1229    begin
1230       pragma Debug (Printk ("procedure Clock called" & LF));
1231
1232       return To_Duration (Rt_Get_Time);
1233    end Monotonic_Clock;
1234
1235    -------------------
1236    -- RT_Resolution --
1237    -------------------
1238
1239    function RT_Resolution return Duration is
1240    begin
1241       return 10#1.0#E-6;
1242    end RT_Resolution;
1243
1244    ------------
1245    -- Wakeup --
1246    ------------
1247
1248    procedure Wakeup (T : Task_ID; Reason : ST.Task_States) is
1249       Flags : Integer;
1250    begin
1251       pragma Debug (Printk ("procedure Wakeup called" & LF));
1252
1253       T.Common.State := Reason;
1254       T.Common.LL.State := RT_TASK_READY;
1255
1256       R_Save_Flags (Flags);
1257       R_Cli;
1258
1259       if Timer_Queue.Common.LL.Succ = To_Address (T) then
1260          --  T is the first task in Timer_Queue, further check
1261
1262          if T.Common.LL.Succ = Timer_Queue'Address then
1263             --  T is the only task in Timer_Queue, so deactivate timer
1264
1265             Rt_No_Timer;
1266
1267          else
1268             --  T is the first task in Timer_Queue, so set timer to T's
1269             --  successor's Resume_Time
1270
1271             Rt_Set_Timer (To_Task_ID (T.Common.LL.Succ).Common.LL.Resume_Time);
1272          end if;
1273       end if;
1274
1275       Delete_T (T);
1276
1277       --  If T is in Timer_Queue, T is removed. If not, nothing happened
1278
1279       Insert_R (T);
1280       R_Restore_Flags (Flags);
1281
1282       Rt_Schedule;
1283    end Wakeup;
1284
1285    -----------
1286    -- Yield --
1287    -----------
1288
1289    procedure Yield (Do_Yield : Boolean := True) is
1290       Flags : Integer;
1291    begin
1292       pragma Debug (Printk ("procedure Yield called" & LF));
1293
1294       pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
1295
1296       R_Save_Flags (Flags);
1297       R_Cli;
1298       Delete_R (Current_Task);
1299       Insert_R (Current_Task);
1300
1301       --  Remove Current_Task from the top of the Ready_Queue
1302       --  and reinsert it back at proper position (the end of
1303       --  tasks with the same active priority).
1304
1305       R_Restore_Flags (Flags);
1306       Rt_Schedule;
1307    end Yield;
1308
1309    ------------------
1310    -- Set_Priority --
1311    ------------------
1312
1313    --  This version implicitly assume that T is the Current_Task
1314
1315    procedure Set_Priority
1316      (T                   : Task_ID;
1317       Prio                : System.Any_Priority;
1318       Loss_Of_Inheritance : Boolean := False)
1319    is
1320       Flags : Integer;
1321    begin
1322       pragma Debug (Printk ("procedure Set_Priority called" & LF));
1323       pragma Assert (T = Self);
1324
1325       T.Common.Current_Priority := Prio;
1326
1327       if T.Common.LL.Outer_Lock /= null then
1328          --  If the task T is holding any lock, defer the priority change
1329          --  until the lock is released. That is, T's Active_Priority will
1330          --  be set to Prio after it unlocks the outer-most lock. See
1331          --  Unlock for detail.
1332          --  Nothing needs to be done here for this case
1333
1334          null;
1335       else
1336          --  If T is not holding any lock, change the priority right away.
1337
1338          R_Save_Flags (Flags);
1339          R_Cli;
1340          T.Common.LL.Active_Priority := Prio;
1341          Delete_R (T);
1342          Insert_RF (T);
1343
1344          --  Insert at the front of the queue for its new priority
1345
1346          R_Restore_Flags (Flags);
1347       end if;
1348
1349       Rt_Schedule;
1350    end Set_Priority;
1351
1352    ------------------
1353    -- Get_Priority --
1354    ------------------
1355
1356    function Get_Priority (T : Task_ID) return System.Any_Priority is
1357    begin
1358       pragma Debug (Printk ("procedure Get_Priority called" & LF));
1359
1360       return T.Common.Current_Priority;
1361    end Get_Priority;
1362
1363    ----------------
1364    -- Enter_Task --
1365    ----------------
1366
1367    --  Do any target-specific initialization that is needed for a new task
1368    --  that has to be done by the task itself. This is called from the task
1369    --  wrapper, immediately after the task starts execution.
1370
1371    procedure Enter_Task (Self_ID : Task_ID) is
1372    begin
1373       --  Use this as "hook" to re-enable interrupts.
1374       pragma Debug (Printk ("procedure Enter_Task called" & LF));
1375
1376       R_Sti;
1377    end Enter_Task;
1378
1379    ----------------
1380    --  New_ATCB  --
1381    ----------------
1382
1383    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
1384       T : constant Task_ID := Available_TCBs;
1385    begin
1386       pragma Debug (Printk ("function New_ATCB called" & LF));
1387
1388       if Entry_Num /= 0 then
1389          --  We are preallocating all TCBs, so they must all have the
1390          --  same number of entries, which means the value of
1391          --  Entry_Num must be bounded.  We probably could choose a
1392          --  non-zero upper bound here, but the Ravenscar Profile
1393          --  specifies that there be no task entries.
1394          --  ???
1395          --  Later, do something better for recovery from this error.
1396
1397          null;
1398       end if;
1399
1400       if T /= null then
1401          Available_TCBs := To_Task_ID (T.Common.LL.Next);
1402          T.Common.LL.Next := System.Null_Address;
1403          Known_Tasks (T.Known_Tasks_Index) := T;
1404       end if;
1405
1406       return T;
1407    end New_ATCB;
1408
1409    ----------------------
1410    --  Initialize_TCB  --
1411    ----------------------
1412
1413    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
1414    begin
1415       pragma Debug (Printk ("procedure Initialize_TCB called" & LF));
1416
1417       --  Give the task a unique serial number.
1418
1419       Self_ID.Serial_Number := Next_Serial_Number;
1420       Next_Serial_Number := Next_Serial_Number + 1;
1421       pragma Assert (Next_Serial_Number /= 0);
1422
1423       Self_ID.Common.LL.L.Ceiling_Priority := System.Any_Priority'Last;
1424       Self_ID.Common.LL.L.Owner := System.Null_Address;
1425       Succeeded := True;
1426    end Initialize_TCB;
1427
1428    -----------------
1429    -- Create_Task --
1430    -----------------
1431
1432    procedure Create_Task
1433      (T          : Task_ID;
1434       Wrapper    : System.Address;
1435       Stack_Size : System.Parameters.Size_Type;
1436       Priority   : System.Any_Priority;
1437       Succeeded  : out Boolean)
1438    is
1439       Adjusted_Stack_Size : Integer;
1440       Bottom              : System.Address;
1441       Flags               : Integer;
1442
1443    begin
1444       pragma Debug (Printk ("procedure Create_Task called" & LF));
1445
1446       Succeeded := True;
1447
1448       if T.Common.LL.Magic = RT_TASK_MAGIC then
1449          Succeeded := False;
1450          return;
1451       end if;
1452
1453       if Stack_Size = Unspecified_Size then
1454          Adjusted_Stack_Size := To_Integer (Default_Stack_Size);
1455       elsif Stack_Size < Minimum_Stack_Size then
1456          Adjusted_Stack_Size := To_Integer (Minimum_Stack_Size);
1457       else
1458          Adjusted_Stack_Size := To_Integer (Stack_Size);
1459       end if;
1460
1461       Bottom := Kmalloc (Adjusted_Stack_Size, GFP_KERNEL);
1462
1463       if Bottom = System.Null_Address then
1464          Succeeded := False;
1465          return;
1466       end if;
1467
1468       T.Common.LL.Uses_Fp          := 1;
1469
1470       --  This field has to be reset to 1 if T uses FP unit. But, without
1471       --  a library-level procedure provided by this package, it cannot
1472       --  be set easily. So temporarily, set it to 1 (which means all the
1473       --  tasks will use FP unit. ???
1474
1475       T.Common.LL.Magic            := RT_TASK_MAGIC;
1476       T.Common.LL.State            := RT_TASK_READY;
1477       T.Common.LL.Succ             := To_Address (T);
1478       T.Common.LL.Pred             := To_Address (T);
1479       T.Common.LL.Active_Priority  := Priority;
1480       T.Common.Current_Priority    := Priority;
1481
1482       T.Common.LL.Stack_Bottom := Bottom;
1483       T.Common.LL.Stack := Bottom + Storage_Offset (Adjusted_Stack_Size);
1484
1485       --  Store the value T into the stack, so that Task_wrapper (defined
1486       --  in System.Tasking.Stages) will find that value for its parameter
1487       --  Self_ID, when the scheduler eventually transfers control to the
1488       --  new task.
1489
1490       T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
1491       To_Address_Ptr (T.Common.LL.Stack).all := To_Address (T);
1492
1493       --  Leave space for the return address, which will not be used,
1494       --  since the task wrapper should never return.
1495
1496       T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
1497       To_Address_Ptr (T.Common.LL.Stack).all := System.Null_Address;
1498
1499       --  Put the entry point address of the task wrapper
1500       --  procedure on the new top of the stack.
1501
1502       T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
1503       To_Address_Ptr (T.Common.LL.Stack).all := Wrapper;
1504
1505       R_Save_Flags (Flags);
1506       R_Cli;
1507       Insert_R (T);
1508       R_Restore_Flags (Flags);
1509    end Create_Task;
1510
1511    ------------------
1512    -- Finalize_TCB --
1513    ------------------
1514
1515    procedure Finalize_TCB (T : Task_ID) is
1516    begin
1517       pragma Debug (Printk ("procedure Finalize_TCB called" & LF));
1518
1519       pragma Assert (T.Common.LL.Succ = To_Address (T));
1520
1521       if T.Common.LL.State = RT_TASK_DORMANT then
1522          Known_Tasks (T.Known_Tasks_Index) := null;
1523          T.Common.LL.Next := To_Address (Available_TCBs);
1524          Available_TCBs := T;
1525          Kfree (T.Common.LL.Stack_Bottom);
1526       end if;
1527    end Finalize_TCB;
1528
1529    ---------------
1530    -- Exit_Task --
1531    ---------------
1532
1533    procedure Exit_Task is
1534       Flags : Integer;
1535    begin
1536       pragma Debug (Printk ("procedure Exit_Task called" & LF));
1537       pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
1538       pragma Assert (Current_Task /= Environment_Task_ID);
1539
1540       R_Save_Flags (Flags);
1541       R_Cli;
1542       Current_Task.Common.LL.State := RT_TASK_DORMANT;
1543       Current_Task.Common.LL.Magic := 0;
1544       Delete_R (Current_Task);
1545       R_Restore_Flags (Flags);
1546       Rt_Schedule;
1547    end Exit_Task;
1548
1549    ----------------
1550    -- Abort_Task --
1551    ----------------
1552
1553    --  ??? Not implemented for now
1554
1555    procedure Abort_Task (T : Task_ID) is
1556    --  Should cause T to raise Abort_Signal the next time it
1557    --  executes.
1558    --  ??? Can this ever be called when T = Current_Task?
1559    --  To be safe, do nothing in this case.
1560    begin
1561       pragma Debug (Printk ("procedure Abort_Task called" & LF));
1562       null;
1563    end Abort_Task;
1564
1565    ----------------
1566    -- Check_Exit --
1567    ----------------
1568
1569    --  Dummy versions. The only currently working versions is for solaris
1570    --  (native).
1571    --  We should probably copy the working versions over from the Solaris
1572    --  version of this package, with any appropriate changes, since without
1573    --  the checks on it will probably be nearly impossible to debug the
1574    --  run-time system.
1575
1576    --  Not implemented for now
1577
1578    function Check_Exit (Self_ID : Task_ID) return Boolean is
1579    begin
1580       pragma Debug (Printk ("function Check_Exit called" & LF));
1581
1582       return True;
1583    end Check_Exit;
1584
1585    --------------------
1586    -- Check_No_Locks --
1587    --------------------
1588
1589    function Check_No_Locks (Self_ID : Task_ID) return Boolean is
1590    begin
1591       pragma Debug (Printk ("function Check_No_Locks called" & LF));
1592
1593       if Self_ID.Common.LL.Outer_Lock = null then
1594          return True;
1595       else
1596          return False;
1597       end if;
1598    end Check_No_Locks;
1599
1600    ----------------------
1601    -- Environment_Task --
1602    ----------------------
1603
1604    function Environment_Task return Task_ID is
1605    begin
1606       return Environment_Task_ID;
1607    end Environment_Task;
1608
1609    --------------
1610    -- Lock_RTS --
1611    --------------
1612
1613    procedure Lock_RTS is
1614    begin
1615       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1616    end Lock_RTS;
1617
1618    ----------------
1619    -- Unlock_RTS --
1620    ----------------
1621
1622    procedure Unlock_RTS is
1623    begin
1624       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1625    end Unlock_RTS;
1626
1627    -----------------
1628    -- Stack_Guard --
1629    -----------------
1630
1631    --  Not implemented for now
1632
1633    procedure Stack_Guard (T : Task_ID; On : Boolean) is
1634    begin
1635       null;
1636    end Stack_Guard;
1637
1638    --------------------
1639    -- Get_Thread_Id  --
1640    --------------------
1641
1642    function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is
1643    begin
1644       return To_Address (T);
1645    end Get_Thread_Id;
1646
1647    ------------------
1648    -- Suspend_Task --
1649    ------------------
1650
1651    function Suspend_Task
1652      (T           : Task_ID;
1653       Thread_Self : OSI.Thread_Id) return Boolean is
1654    begin
1655       return False;
1656    end Suspend_Task;
1657
1658    -----------------
1659    -- Resume_Task --
1660    -----------------
1661
1662    function Resume_Task
1663      (T           : ST.Task_ID;
1664       Thread_Self : OSI.Thread_Id) return Boolean is
1665    begin
1666       return False;
1667    end Resume_Task;
1668
1669    -----------------
1670    -- Init_Module --
1671    -----------------
1672
1673    function Init_Module return Integer is
1674       procedure adainit;
1675       pragma Import (C, adainit);
1676
1677    begin
1678       adainit;
1679       In_Elab_Code := False;
1680       Set_Priority (Environment_Task_ID, Any_Priority'First);
1681       return 0;
1682    end Init_Module;
1683
1684    --------------------
1685    -- Cleanup_Module --
1686    --------------------
1687
1688    procedure Cleanup_Module is
1689       procedure adafinal;
1690       pragma Import (C, adafinal);
1691
1692    begin
1693       adafinal;
1694    end Cleanup_Module;
1695
1696    ----------------
1697    -- Initialize --
1698    ----------------
1699
1700    --  The environment task is "special". The TCB of the environment task is
1701    --  not in the TCB_Array above. Logically, all initialization code for the
1702    --  runtime system is executed by the environment task, but until the
1703    --  environment task has initialized its own TCB we dare not execute any
1704    --  calls that try to access the TCB of Current_Task. It is allocated by
1705    --  target-independent runtime system code, in System.Tasking.Initializa-
1706    --  tion.Init_RTS, before the call to this procedure Initialize. The
1707    --  target-independent runtime system initializes all the components that
1708    --  are target-independent, but this package needs to be given a chance to
1709    --  initialize the target-dependent data.  We do that in this procedure.
1710
1711    --  In the present implementation, Environment_Task is set to be the
1712    --  regular GNU/Linux kernel task.
1713
1714    procedure Initialize (Environment_Task : Task_ID) is
1715    begin
1716       pragma Debug (Printk ("procedure Initialize called" & LF));
1717
1718       Environment_Task_ID := Environment_Task;
1719
1720       --  Build the list of available ATCB's.
1721
1722       Available_TCBs := To_Task_ID (TCB_Array (1)'Address);
1723
1724       for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop
1725          --  Note that the zeroth element in TCB_Array is not used, see
1726          --  comments following the declaration of TCB_Array
1727
1728          TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address;
1729       end loop;
1730
1731       TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address;
1732
1733       --  Initialize the idle task, which is the head of Ready_Queue.
1734
1735       Idle_Task.Common.LL.Magic := RT_TASK_MAGIC;
1736       Idle_Task.Common.LL.State := RT_TASK_READY;
1737       Idle_Task.Common.Current_Priority := System.Any_Priority'First;
1738       Idle_Task.Common.LL.Active_Priority  := System.Any_Priority'First;
1739       Idle_Task.Common.LL.Succ := Idle_Task'Address;
1740       Idle_Task.Common.LL.Pred := Idle_Task'Address;
1741
1742       --  Initialize the regular GNU/Linux kernel task.
1743
1744       Environment_Task.Common.LL.Magic := RT_TASK_MAGIC;
1745       Environment_Task.Common.LL.State := RT_TASK_READY;
1746       Environment_Task.Common.Current_Priority := System.Any_Priority'First;
1747       Environment_Task.Common.LL.Active_Priority  := System.Any_Priority'First;
1748       Environment_Task.Common.LL.Succ := To_Address (Environment_Task);
1749       Environment_Task.Common.LL.Pred := To_Address (Environment_Task);
1750
1751       --  Initialize the head of Timer_Queue
1752
1753       Timer_Queue.Common.LL.Succ        := Timer_Queue'Address;
1754       Timer_Queue.Common.LL.Pred        := Timer_Queue'Address;
1755       Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay;
1756
1757       --  Set the current task to regular GNU/Linux kernel task
1758
1759       Current_Task := Environment_Task;
1760
1761       --  Set Timer_Wrapper to be the timer handler
1762
1763       Rt_Free_Timer;
1764       Rt_Request_Timer (Timer_Wrapper'Address);
1765
1766       --  Initialize the lock used to synchronize chain of all ATCBs.
1767
1768       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1769
1770       --  Single_Lock isn't supported in this configuration
1771       pragma Assert (not Single_Lock);
1772
1773       Enter_Task (Environment_Task);
1774    end Initialize;
1775
1776 end System.Task_Primitives.Operations;