?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config/xtensa/linux.h (TARGET_OS_CPP_BUILTINS): Remove definition of
[official-gcc.git] / gcc / ada / 5qtaprop.adb
blobaa1e97be6942702a7813e0ed7a78417020404b83
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;
Mirror of the offical gcc git repository hosted at gcc.gnu.org