1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . A S T _ H A N D L I N G --
9 -- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
11 -- GNAT 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. GNAT 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 GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the OpenVMS/Alpha version.
36 with System
; use System
;
40 with System
.Machine_Code
;
41 with System
.Storage_Elements
;
44 with System
.Tasking
.Rendezvous
;
45 with System
.Tasking
.Initialization
;
46 with System
.Tasking
.Utilities
;
48 with System
.Task_Primitives
;
49 with System
.Task_Primitives
.Operations
;
50 with System
.Task_Primitives
.Operations
.DEC
;
52 -- with Ada.Finalization;
53 -- removed, because of problem with controlled attribute ???
55 with Ada
.Task_Attributes
;
56 with Ada
.Task_Identification
;
58 with Ada
.Exceptions
; use Ada
.Exceptions
;
60 with Ada
.Unchecked_Conversion
;
62 package body System
.AST_Handling
is
64 package ATID
renames Ada
.Task_Identification
;
66 package ST
renames System
.Tasking
;
67 package STR
renames System
.Tasking
.Rendezvous
;
68 package STI
renames System
.Tasking
.Initialization
;
69 package STU
renames System
.Tasking
.Utilities
;
71 package SSE
renames System
.Storage_Elements
;
72 package STPO
renames System
.Task_Primitives
.Operations
;
73 package STPOD
renames System
.Task_Primitives
.Operations
.DEC
;
75 AST_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
76 -- This is a global lock; it is used to execute in mutual exclusion
77 -- from all other AST tasks. It is only used by Lock_AST and
80 procedure Lock_AST
(Self_ID
: ST
.Task_ID
);
81 -- Locks out other AST tasks. Preceding a section of code by Lock_AST and
82 -- following it by Unlock_AST creates a critical region.
84 procedure Unlock_AST
(Self_ID
: ST
.Task_ID
);
85 -- Releases lock previously set by call to Lock_AST.
86 -- All nested locks must be released before other tasks competing for the
87 -- tasking lock are released.
93 procedure Lock_AST
(Self_ID
: ST
.Task_ID
) is
95 STI
.Defer_Abort_Nestable
(Self_ID
);
96 STPO
.Write_Lock
(AST_Lock
'Access);
103 procedure Unlock_AST
(Self_ID
: ST
.Task_ID
) is
105 STPO
.Unlock
(AST_Lock
'Access);
106 STI
.Undefer_Abort_Nestable
(Self_ID
);
109 ---------------------------------
110 -- AST_Handler Data Structures --
111 ---------------------------------
113 -- As noted in the private part of the spec of System.Aux_DEC, the
114 -- AST_Handler type is simply a pointer to a procedure that takes
115 -- a single 64bit parameter. The following is a local copy
116 -- of that definition.
118 -- We need our own copy because we need to get our hands on this
119 -- and we cannot see the private part of System.Aux_DEC. We don't
120 -- want to be a child of Aux_Dec because of complications resulting
121 -- from the use of pragma Extend_System. We will use unchecked
122 -- conversions between the two versions of the declarations.
124 type AST_Handler
is access procedure (Param
: Long_Integer);
126 -- However, this declaration is somewhat misleading, since the values
127 -- referenced by AST_Handler values (all produced in this package by
128 -- calls to Create_AST_Handler) are highly stylized.
130 -- The first point is that in VMS/Alpha, procedure pointers do not in
131 -- fact point to code, but rather to a 48-byte procedure descriptor.
132 -- So a value of type AST_Handler is in fact a pointer to one of these
133 -- 48-byte descriptors.
135 type Descriptor_Type
is new SSE
.Storage_Array
(1 .. 48);
136 for Descriptor_Type
'Alignment use Standard
'Maximum_Alignment;
137 type Descriptor_Ref
is access all Descriptor_Type
;
139 -- Normally, there is only one such descriptor for a given procedure, but
140 -- it works fine to make a copy of the single allocated descriptor, and
141 -- use the copy itself, and we take advantage of this in the design here.
142 -- The idea is that AST_Handler values will all point to a record with the
143 -- following structure:
145 -- Note: When we say it works fine, there is one delicate point, which
146 -- is that the code for the AST procedure itself requires the original
147 -- descriptor address. We handle this by saving the orignal descriptor
148 -- address in this structure and restoring in Process_AST.
150 type AST_Handler_Data
is record
151 Descriptor
: Descriptor_Type
;
152 Original_Descriptor_Ref
: Descriptor_Ref
;
153 Taskid
: ATID
.Task_Id
;
157 type AST_Handler_Data_Ref
is access all AST_Handler_Data
;
159 function To_AST_Handler
is new Ada
.Unchecked_Conversion
160 (AST_Handler_Data_Ref
, System
.Aux_DEC
.AST_Handler
);
162 -- Each time Create_AST_Handler is called, a new value of this record
163 -- type is created, containing a copy of the procedure descriptor for
164 -- the routine used to handle all AST's (Process_AST), and the Task_Id
165 -- and entry number parameters identifying the task entry involved.
167 -- The AST_Handler value returned is a pointer to this record. Since
168 -- the record starts with the procedure descriptor, it can be used
169 -- by the system in the normal way to call the procedure. But now
170 -- when the procedure gets control, it can determine the address of
171 -- the procedure descriptor used to call it (since the ABI specifies
172 -- that this is left sitting in register r27 on entry), and then use
173 -- that address to retrieve the Task_Id and entry number so that it
174 -- knows on which entry to queue the AST request.
176 -- The next issue is where are these records placed. Since we intend
177 -- to pass pointers to these records to asynchronous system service
178 -- routines, they have to be on the heap, which means we have to worry
179 -- about when to allocate them and deallocate them.
181 -- We solve this problem by introducing a task attribute that points to
182 -- a vector, indexed by the entry number, of AST_Handler_Data records
183 -- for a given task. The pointer itself is a controlled object allowing
184 -- us to write a finalization routine that frees the referenced vector.
186 -- An entry in this vector is either initialized (Entryno non-zero) and
187 -- can be used for any subsequent reference to the same entry, or it is
188 -- unused, marked by the Entryno value being zero.
190 type AST_Handler_Vector
is array (Natural range <>) of AST_Handler_Data
;
191 type AST_Handler_Vector_Ref
is access all AST_Handler_Vector
;
193 -- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
194 -- removed due to problem with controlled attribute, consequence is that
195 -- we have a memory leak if a task that has AST attribute entries is
198 type AST_Vector_Ptr
is record
199 Vector
: AST_Handler_Vector_Ref
;
202 AST_Vector_Init
: AST_Vector_Ptr
;
203 -- Initial value, treated as constant, Vector will be null.
205 package AST_Attribute
is new Ada
.Task_Attributes
206 (Attribute
=> AST_Vector_Ptr
,
207 Initial_Value
=> AST_Vector_Init
);
211 -----------------------
212 -- AST Service Queue --
213 -----------------------
215 -- The following global data structures are used to queue pending
216 -- AST requests. When an AST is signalled, the AST service routine
217 -- Process_AST is called, and it makes an entry in this structure.
219 type AST_Instance
is record
220 Taskid
: ATID
.Task_Id
;
222 Param
: Long_Integer;
224 -- The Taskid and Entryno indicate the entry on which this AST is to
225 -- be queued, and Param is the parameter provided from the AST itself.
227 AST_Service_Queue_Size
: constant := 256;
228 AST_Service_Queue_Limit
: constant := 250;
229 type AST_Service_Queue_Index
is mod AST_Service_Queue_Size
;
230 -- Index used to refer to entries in the circular buffer which holds
231 -- active AST_Instance values. The upper bound reflects the maximum
232 -- number of AST instances that can be stored in the buffer. Since
233 -- these entries are immediately serviced by the high priority server
234 -- task that does the actual entry queuing, it is very unusual to have
235 -- any significant number of entries simulaneously queued.
237 AST_Service_Queue
: array (AST_Service_Queue_Index
) of AST_Instance
;
238 pragma Volatile_Components
(AST_Service_Queue
);
239 -- The circular buffer used to store active AST requests.
241 AST_Service_Queue_Put
: AST_Service_Queue_Index
:= 0;
242 AST_Service_Queue_Get
: AST_Service_Queue_Index
:= 0;
243 pragma Atomic
(AST_Service_Queue_Put
);
244 pragma Atomic
(AST_Service_Queue_Get
);
245 -- These two variables point to the next slots in the AST_Service_Queue
246 -- to be used for putting a new entry in and taking an entry out. This
247 -- is a circular buffer, so these pointers wrap around. If the two values
248 -- are equal the buffer is currently empty. The pointers are atomic to
249 -- ensure proper synchronization between the single producer (namely the
250 -- Process_AST procedure), and the single consumer (the AST_Service_Task).
252 --------------------------------
253 -- AST Server Task Structures --
254 --------------------------------
256 -- The basic approach is that when an AST comes in, a call is made to
257 -- the Process_AST procedure. It queues the request in the service queue
258 -- and then wakes up an AST server task to perform the actual call to the
259 -- required entry. We use this intermediate server task, since the AST
260 -- procedure itself cannot wait to return, and we need some caller for
261 -- the rendezvous so that we can use the normal rendezvous mechanism.
263 -- It would work to have only one AST server task, but then we would lose
264 -- all overlap in AST processing, and furthermore, we could get priority
265 -- inversion effects resulting in starvation of AST requests.
267 -- We therefore maintain a small pool of AST server tasks. We adjust
268 -- the size of the pool dynamically to reflect traffic, so that we have
269 -- a sufficient number of server tasks to avoid starvation.
271 Max_AST_Servers
: constant Natural := 16;
272 -- Maximum number of AST server tasks that can be allocated
274 Num_AST_Servers
: Natural := 0;
275 -- Number of AST server tasks currently active
277 Num_Waiting_AST_Servers
: Natural := 0;
278 -- This is the number of AST server tasks that are either waiting for
279 -- work, or just about to go to sleep and wait for work.
281 Is_Waiting
: array (1 .. Max_AST_Servers
) of Boolean := (others => False);
282 -- An array of flags showing which AST server tasks are currently waiting
284 AST_Task_Ids
: array (1 .. Max_AST_Servers
) of ST
.Task_ID
;
285 -- Task Id's of allocated AST server tasks
287 task type AST_Server_Task
(Num
: Natural) is
288 pragma Priority
(Priority
'Last);
290 -- Declaration for AST server task. This task has no entries, it is
291 -- controlled by sleep and wakeup calls at the task primitives level.
293 type AST_Server_Task_Ptr
is access all AST_Server_Task
;
294 -- Type used to allocate server tasks
296 -----------------------
297 -- Local Subprograms --
298 -----------------------
300 procedure Allocate_New_AST_Server
;
301 -- Allocate an additional AST server task
303 procedure Process_AST
(Param
: Long_Integer);
304 -- This is the central routine for processing all AST's, it is referenced
305 -- as the code address of all created AST_Handler values. See detailed
306 -- description in body to understand how it works to have a single such
307 -- procedure for all AST's even though it does not get any indication of
308 -- the entry involved passed as an explicit parameter. The single explicit
309 -- parameter Param is the parameter passed by the system with the AST.
311 -----------------------------
312 -- Allocate_New_AST_Server --
313 -----------------------------
315 procedure Allocate_New_AST_Server
is
316 Dummy
: AST_Server_Task_Ptr
;
319 if Num_AST_Servers
= Max_AST_Servers
then
323 -- Note: it is safe to increment Num_AST_Servers immediately, since
324 -- no one will try to activate this task until it indicates that it
325 -- is sleeping by setting its entry in Is_Waiting to True.
327 Num_AST_Servers
:= Num_AST_Servers
+ 1;
328 Dummy
:= new AST_Server_Task
(Num_AST_Servers
);
330 end Allocate_New_AST_Server
;
332 ---------------------
333 -- AST_Server_Task --
334 ---------------------
336 task body AST_Server_Task
is
337 Taskid
: ATID
.Task_Id
;
339 Param
: aliased Long_Integer;
340 Self_Id
: constant ST
.Task_ID
:= ST
.Self
;
342 pragma Volatile
(Param
);
345 -- By making this task independent of master, when the environment
346 -- task is finalizing, the AST_Server_Task will be notified that it
349 STU
.Make_Independent
;
351 -- Record our task Id for access by Process_AST
353 AST_Task_Ids
(Num
) := Self_Id
;
355 -- Note: this entire task operates with the main task lock set, except
356 -- when it is sleeping waiting for work, or busy doing a rendezvous
357 -- with an AST server. This lock protects the data structures that
358 -- are shared by multiple instances of the server task.
362 -- This is the main infinite loop of the task. We go to sleep and
363 -- wait to be woken up by Process_AST when there is some work to do.
366 Num_Waiting_AST_Servers
:= Num_Waiting_AST_Servers
+ 1;
368 Unlock_AST
(Self_Id
);
370 STI
.Defer_Abort
(Self_Id
);
371 STPO
.Write_Lock
(Self_Id
);
373 Is_Waiting
(Num
) := True;
375 Self_Id
.Common
.State
:= ST
.AST_Server_Sleep
;
376 STPO
.Sleep
(Self_Id
, ST
.AST_Server_Sleep
);
377 Self_Id
.Common
.State
:= ST
.Runnable
;
379 STPO
.Unlock
(Self_Id
);
381 -- If the process is finalizing, Undefer_Abort will simply end
384 STI
.Undefer_Abort
(Self_Id
);
386 -- We are awake, there is something to do!
389 Num_Waiting_AST_Servers
:= Num_Waiting_AST_Servers
- 1;
391 -- Loop here to service outstanding requests. We are always
392 -- locked on entry to this loop.
394 while AST_Service_Queue_Get
/= AST_Service_Queue_Put
loop
395 Taskid
:= AST_Service_Queue
(AST_Service_Queue_Get
).Taskid
;
396 Entryno
:= AST_Service_Queue
(AST_Service_Queue_Get
).Entryno
;
397 Param
:= AST_Service_Queue
(AST_Service_Queue_Get
).Param
;
399 AST_Service_Queue_Get
:= AST_Service_Queue_Get
+ 1;
401 -- This is a manual expansion of the normal call simple code
404 type AA
is access all Long_Integer;
405 P
: AA
:= Param
'Unrestricted_Access;
407 function To_ST_Task_Id
is new Ada
.Unchecked_Conversion
408 (ATID
.Task_Id
, ST
.Task_ID
);
411 Unlock_AST
(Self_Id
);
413 (Acceptor
=> To_ST_Task_Id
(Taskid
),
414 E
=> ST
.Task_Entry_Index
(Entryno
),
415 Uninterpreted_Data
=> P
'Address);
418 System
.IO
.Put_Line
("%Debugging event");
419 System
.IO
.Put_Line
(Exception_Name
(E
) &
420 " raised when trying to deliver an AST.");
421 if Exception_Message
(E
)'Length /= 0 then
422 System
.IO
.Put_Line
(Exception_Message
(E
));
424 System
.IO
.Put_Line
("Task type is " & "Receiver_Type");
425 System
.IO
.Put_Line
("Task id is " & ATID
.Image
(Taskid
));
433 ------------------------
434 -- Create_AST_Handler --
435 ------------------------
437 function Create_AST_Handler
438 (Taskid
: ATID
.Task_Id
;
440 return System
.Aux_DEC
.AST_Handler
442 Attr_Ref
: Attribute_Handle
;
444 Process_AST_Ptr
: constant AST_Handler
:= Process_AST
'Access;
445 -- Reference to standard procedure descriptor for Process_AST
447 function To_Descriptor_Ref
is new Ada
.Unchecked_Conversion
448 (AST_Handler
, Descriptor_Ref
);
450 Original_Descriptor_Ref
: Descriptor_Ref
:=
451 To_Descriptor_Ref
(Process_AST_Ptr
);
454 if ATID
.Is_Terminated
(Taskid
) then
458 Attr_Ref
:= Reference
(Taskid
);
460 -- Allocate another server if supply is getting low
462 if Num_Waiting_AST_Servers
< 2 then
463 Allocate_New_AST_Server
;
466 -- No point in creating more if we have zillions waiting to
469 while AST_Service_Queue_Put
- AST_Service_Queue_Get
470 > AST_Service_Queue_Limit
475 -- If no AST vector allocated, or the one we have is too short, then
476 -- allocate one of right size and initialize all entries except the
477 -- one we will use to unused. Note that the assignment automatically
478 -- frees the old allocated table if there is one.
480 if Attr_Ref
.Vector
= null
481 or else Attr_Ref
.Vector
'Length < Entryno
483 Attr_Ref
.Vector
:= new AST_Handler_Vector
(1 .. Entryno
);
485 for E
in 1 .. Entryno
loop
486 Attr_Ref
.Vector
(E
).Descriptor
:=
487 Original_Descriptor_Ref
.all;
488 Attr_Ref
.Vector
(E
).Original_Descriptor_Ref
:=
489 Original_Descriptor_Ref
;
490 Attr_Ref
.Vector
(E
).Taskid
:= Taskid
;
491 Attr_Ref
.Vector
(E
).Entryno
:= E
;
495 return To_AST_Handler
(Attr_Ref
.Vector
(Entryno
)'Unrestricted_Access);
496 end Create_AST_Handler
;
498 ----------------------------
499 -- Expand_AST_Packet_Pool --
500 ----------------------------
502 procedure Expand_AST_Packet_Pool
503 (Requested_Packets
: in Natural;
504 Actual_Number
: out Natural;
505 Total_Number
: out Natural)
508 -- The AST implementation of GNAT does not permit dynamic expansion
509 -- of the pool, so we simply add no entries and return the total. If
510 -- it is necessary to expand the allocation, then this package body
511 -- must be recompiled with a larger value for AST_Service_Queue_Size.
514 Total_Number
:= AST_Service_Queue_Size
;
515 end Expand_AST_Packet_Pool
;
521 procedure Process_AST
(Param
: Long_Integer) is
523 Handler_Data_Ptr
: AST_Handler_Data_Ref
;
524 -- This variable is set to the address of the descriptor through
525 -- which Process_AST is called. Since the descriptor is part of
526 -- an AST_Handler value, this is also the address of this value,
527 -- from which we can obtain the task and entry number information.
529 function To_Address
is new Ada
.Unchecked_Conversion
530 (ST
.Task_ID
, System
.Address
);
533 System
.Machine_Code
.Asm
534 (Template
=> "addl $27,0,%0",
535 Outputs
=> AST_Handler_Data_Ref
'Asm_Output ("=r", Handler_Data_Ptr
),
538 System
.Machine_Code
.Asm
539 (Template
=> "ldl $27,%0",
540 Inputs
=> Descriptor_Ref
'Asm_Input
541 ("m", Handler_Data_Ptr
.Original_Descriptor_Ref
),
544 AST_Service_Queue
(AST_Service_Queue_Put
) := AST_Instance
'
545 (Taskid => Handler_Data_Ptr.Taskid,
546 Entryno => Handler_Data_Ptr.Entryno,
549 -- ??? What is the protection of this variable ?
550 -- It seems that trying to use any lock in this procedure will get
553 AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
555 -- Need to wake up processing task. If there is no waiting server
556 -- then we have temporarily run out, but things should still be
557 -- OK, since one of the active ones will eventually pick up the
558 -- service request queued in the AST_Service_Queue.
560 for J in 1 .. Num_AST_Servers loop
561 if Is_Waiting (J) then
562 Is_Waiting (J) := False;
564 -- Sleeps are handled by ASTs on VMS, so don't call Wakeup.
565 -- ??? We should lock AST_Task_Ids (J) here. What's the story ?
567 STPOD.Interrupt_AST_Handler
568 (To_Address (AST_Task_Ids (J)));
575 STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
576 end System.AST_Handling;