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