?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Add an UNSPEC_PROLOGUE_USE to prevent the link register from being considered dead.
[official-gcc.git] / gcc / ada / 5qtaprop.adb
blob52c09cff7ec4d8e8a2fdc4c2abc6e7c5fb109c43
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 -- --
10 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
11 -- --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
29 -- --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
32 -- --
33 ------------------------------------------------------------------------------
34
35 -- RT GNU/Linux version
36
37 -- ???? Later, look at what we might want to provide for interrupt
38 -- management.
39
40 pragma Suppress (All_Checks);
41
42 pragma Polling (Off);
43 -- Turn off polling, we do not want ATC polling to take place during
44 -- tasking operations. It causes infinite loops and other problems.
45
46 with System.Machine_Code;
47 -- used for Asm
48
49 with System.OS_Interface;
50 -- used for various types, constants, and operations
51
52 with System.OS_Primitives;
53 -- used for Delay_Modes
54
55 with System.Parameters;
56 -- used for Size_Type
57
58 with System.Storage_Elements;
59
60 with System.Tasking;
61 -- used for Ada_Task_Control_Block
62 -- Task_ID
63
64 with Ada.Unchecked_Conversion;
65
66 package body System.Task_Primitives.Operations is
67
68 use System.Machine_Code,
69 System.OS_Interface,
70 System.OS_Primitives,
71 System.Parameters,
72 System.Tasking,
73 System.Storage_Elements;
74
75 --------------------------------
76 -- RT GNU/Linux specific Data --
77 --------------------------------
78
79 -- Define two important parameters necessary for a GNU/Linux kernel module.
80 -- Any module that is going to be loaded into the kernel space needs these
81 -- parameters.
82
83 Mod_Use_Count : Integer;
84 pragma Export (C, Mod_Use_Count, "mod_use_count_");
85 -- for module usage tracking by the kernel
86
87 type Aliased_String is array (Positive range <>) of aliased Character;
88 pragma Convention (C, Aliased_String);
89
90 Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul;
91 pragma Export (C, Kernel_Version, "kernel_version");
92 -- So that insmod can find the version number.
93
94 -- The following procedures have their name specified by the GNU/Linux
95 -- module loader. Note that they simply correspond to adainit/adafinal.
96
97 function Init_Module return Integer;
98 pragma Export (C, Init_Module, "init_module");
99
100 procedure Cleanup_Module;
101 pragma Export (C, Cleanup_Module, "cleanup_module");
102
103 ----------------
104 -- Local Data --
105 ----------------
106
107 LF : constant String := ASCII.LF & ASCII.Nul;
108
109 LFHT : constant String := ASCII.LF & ASCII.HT;
110 -- used in inserted assembly code
111
112 Max_Tasks : constant := 10;
113 -- ??? Eventually, this should probably be in System.Parameters.
114
115 Known_Tasks : array (0 .. Max_Tasks) of Task_ID;
116 -- Global array of tasks read by gdb, and updated by Create_Task and
117 -- Finalize_TCB. It's from System.Tasking.Debug. We moved it here to
118 -- cut the dependence on that package. Consider moving it here or to
119 -- this package specification, permanently????
120
121 Max_Sensible_Delay : constant RTIME :=
122 365 * 24 * 60 * 60 * RT_TICKS_PER_SEC;
123 -- Max of one year delay, needed to prevent exceptions for large
124 -- delay values. It seems unlikely that any test will notice this
125 -- restriction.
126 -- ??? This is really declared in System.OS_Primitives,
127 -- and the type is Duration, here its type is RTIME.
128
129 Tick_Count : constant := RT_TICKS_PER_SEC / 20;
130 Nano_Count : constant := 50_000_000;
131 -- two constants used in conversions between RTIME and Duration.
132
133 Addr_Bytes : constant Storage_Offset :=
134 System.Address'Max_Size_In_Storage_Elements;
135 -- number of bytes needed for storing an address.
136
137 Guess : constant RTIME := 10;
138 -- an approximate amount of RTIME used in scheduler to awake a task having
139 -- its resume time within 'current time + Guess'
140 -- The value of 10 is estimated here and may need further refinement
141
142 TCB_Array : array (0 .. Max_Tasks)
143 of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
144 pragma Volatile_Components (TCB_Array);
145
146 Available_TCBs : Task_ID;
147 pragma Atomic (Available_TCBs);
148 -- Head of linear linked list of available TCB's, linked using TCB's
149 -- LL.Next. This list is Initialized to contain a fixed number of tasks,
150 -- when the runtime system starts up.
151
152 Current_Task : Task_ID;
153 pragma Export (C, Current_Task, "current_task");
154 pragma Atomic (Current_Task);
155 -- This is the task currently running. We need the pragma here to specify
156 -- the link-name for Current_Task is "current_task", rather than the long
157 -- name (including the package name) that the Ada compiler would normally
158 -- generate. "current_task" is referenced in procedure Rt_Switch_To below
159
160 Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
161 -- Tail of the circular queue of ready to run tasks.
162
163 Scheduler_Idle : Boolean := False;
164 -- True when the scheduler is idle (no task other than the idle task
165 -- is on the ready queue).
166
167 In_Elab_Code : Boolean := True;
168 -- True when we are elaborating our application.
169 -- Init_Module will set this flag to false and never revert it.
170
171 Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
172 -- Header of the queue of delayed real-time tasks.
173 -- Timer_Queue.LL has to be initialized properly before being used
174
175 Timer_Expired : Boolean := False;
176 -- flag to show whether the Timer_Queue needs to be checked
177 -- when it becomes true, it means there is a task in the
178 -- Timer_Queue having to be awakened and be moved to ready queue
179
180 Environment_Task_ID : Task_ID;
181 -- A variable to hold Task_ID for the environment task.
182 -- Once initialized, this behaves as a constant.
183 -- In the current implementation, this is the task assigned permanently
184 -- as the regular GNU/Linux kernel.
185
186 Single_RTS_Lock : aliased RTS_Lock;
187 -- This is a lock to allow only one thread of control in the RTS at
188 -- a time; it is used to execute in mutual exclusion from all other tasks.
189 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
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 (L : access Lock; Ceiling_Violation : out Boolean) is
726 Prio : constant System.Any_Priority :=
727 Current_Task.Common.LL.Active_Priority;
728
729 begin
730 pragma Debug (Printk ("procedure Write_Lock called" & LF));
731
732 Ceiling_Violation := False;
733
734 if Prio > L.Ceiling_Priority then
735 -- Ceiling violation.
736 -- This should never happen, unless something is seriously
737 -- wrong with task T or the entire run-time system.
738 -- ???? extreme error recovery, e.g. shut down the system or task
739
740 Ceiling_Violation := True;
741 pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF));
742 return;
743 end if;
744
745 L.Pre_Locking_Priority := Prio;
746 L.Owner := To_Address (Current_Task);
747 Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
748
749 if Current_Task.Common.LL.Outer_Lock = null then
750 -- If this lock is not nested, record a pointer to it.
751
752 Current_Task.Common.LL.Outer_Lock :=
753 To_RTS_Lock_Ptr (L.all'Unchecked_Access);
754 end if;
755 end Write_Lock;
756
757 procedure Write_Lock
758 (L : access RTS_Lock; Global_Lock : Boolean := False)
759 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; Global_Lock : Boolean := False) 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_RTS --
1612 --------------
1613
1614 procedure Lock_RTS is
1615 begin
1616 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1617 end Lock_RTS;
1618
1619 ----------------
1620 -- Unlock_RTS --
1621 ----------------
1622
1623 procedure Unlock_RTS is
1624 begin
1625 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1626 end Unlock_RTS;
1627
1628 -----------------
1629 -- Stack_Guard --
1630 -----------------
1631
1632 -- Not implemented for now
1633
1634 procedure Stack_Guard (T : Task_ID; On : Boolean) is
1635 begin
1636 null;
1637 end Stack_Guard;
1638
1639 --------------------
1640 -- Get_Thread_Id --
1641 --------------------
1642
1643 function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is
1644 begin
1645 return To_Address (T);
1646 end Get_Thread_Id;
1647
1648 ------------------
1649 -- Suspend_Task --
1650 ------------------
1651
1652 function Suspend_Task
1653 (T : Task_ID;
1654 Thread_Self : OSI.Thread_Id) return Boolean is
1655 begin
1656 return False;
1657 end Suspend_Task;
1658
1659 -----------------
1660 -- Resume_Task --
1661 -----------------
1662
1663 function Resume_Task
1664 (T : ST.Task_ID;
1665 Thread_Self : OSI.Thread_Id) return Boolean is
1666 begin
1667 return False;
1668 end Resume_Task;
1669
1670 -----------------
1671 -- Init_Module --
1672 -----------------
1673
1674 function Init_Module return Integer is
1675 procedure adainit;
1676 pragma Import (C, adainit);
1677
1678 begin
1679 adainit;
1680 In_Elab_Code := False;
1681 Set_Priority (Environment_Task_ID, Any_Priority'First);
1682 return 0;
1683 end Init_Module;
1684
1685 --------------------
1686 -- Cleanup_Module --
1687 --------------------
1688
1689 procedure Cleanup_Module is
1690 procedure adafinal;
1691 pragma Import (C, adafinal);
1692
1693 begin
1694 adafinal;
1695 end Cleanup_Module;
1696
1697 ----------------
1698 -- Initialize --
1699 ----------------
1700
1701 -- The environment task is "special". The TCB of the environment task is
1702 -- not in the TCB_Array above. Logically, all initialization code for the
1703 -- runtime system is executed by the environment task, but until the
1704 -- environment task has initialized its own TCB we dare not execute any
1705 -- calls that try to access the TCB of Current_Task. It is allocated by
1706 -- target-independent runtime system code, in System.Tasking.Initializa-
1707 -- tion.Init_RTS, before the call to this procedure Initialize. The
1708 -- target-independent runtime system initializes all the components that
1709 -- are target-independent, but this package needs to be given a chance to
1710 -- initialize the target-dependent data. We do that in this procedure.
1711
1712 -- In the present implementation, Environment_Task is set to be the
1713 -- regular GNU/Linux kernel task.
1714
1715 procedure Initialize (Environment_Task : Task_ID) is
1716 begin
1717 pragma Debug (Printk ("procedure Initialize called" & LF));
1718
1719 Environment_Task_ID := Environment_Task;
1720
1721 -- Build the list of available ATCB's.
1722
1723 Available_TCBs := To_Task_ID (TCB_Array (1)'Address);
1724
1725 for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop
1726 -- Note that the zeroth element in TCB_Array is not used, see
1727 -- comments following the declaration of TCB_Array
1728
1729 TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address;
1730 end loop;
1731
1732 TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address;
1733
1734 -- Initialize the idle task, which is the head of Ready_Queue.
1735
1736 Idle_Task.Common.LL.Magic := RT_TASK_MAGIC;
1737 Idle_Task.Common.LL.State := RT_TASK_READY;
1738 Idle_Task.Common.Current_Priority := System.Any_Priority'First;
1739 Idle_Task.Common.LL.Active_Priority := System.Any_Priority'First;
1740 Idle_Task.Common.LL.Succ := Idle_Task'Address;
1741 Idle_Task.Common.LL.Pred := Idle_Task'Address;
1742
1743 -- Initialize the regular GNU/Linux kernel task.
1744
1745 Environment_Task.Common.LL.Magic := RT_TASK_MAGIC;
1746 Environment_Task.Common.LL.State := RT_TASK_READY;
1747 Environment_Task.Common.Current_Priority := System.Any_Priority'First;
1748 Environment_Task.Common.LL.Active_Priority := System.Any_Priority'First;
1749 Environment_Task.Common.LL.Succ := To_Address (Environment_Task);
1750 Environment_Task.Common.LL.Pred := To_Address (Environment_Task);
1751
1752 -- Initialize the head of Timer_Queue
1753
1754 Timer_Queue.Common.LL.Succ := Timer_Queue'Address;
1755 Timer_Queue.Common.LL.Pred := Timer_Queue'Address;
1756 Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay;
1757
1758 -- Set the current task to regular GNU/Linux kernel task
1759
1760 Current_Task := Environment_Task;
1761
1762 -- Set Timer_Wrapper to be the timer handler
1763
1764 Rt_Free_Timer;
1765 Rt_Request_Timer (Timer_Wrapper'Address);
1766
1767 -- Initialize the lock used to synchronize chain of all ATCBs.
1768
1769 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1770
1771 -- Single_Lock isn't supported in this configuration
1772 pragma Assert (not Single_Lock);
1773
1774 Enter_Task (Environment_Task);
1775 end Initialize;
1776
1777 end System.Task_Primitives.Operations;
Mirror of the offical gcc git repository hosted at gcc.gnu.org