1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . A S T _ H A N D L I N G --
11 -- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 -- This is the OpenVMS/Alpha version.
38 with System; use System;
42 with System.Machine_Code;
43 with System.Storage_Elements;
46 with System.Tasking.Rendezvous;
47 with System.Tasking.Initialization;
48 with System.Tasking.Utilities;
50 with System.Task_Primitives;
51 with System.Task_Primitives.Operations;
52 with System.Task_Primitives.Operations.DEC;
54 -- with Ada.Finalization;
55 -- removed, because of problem with controlled attribute ???
57 with Ada.Task_Attributes;
58 with Ada.Task_Identification;
60 with Ada.Exceptions; use Ada.Exceptions;
62 with Ada.Unchecked_Conversion;
63 with Ada.Unchecked_Deallocation;
65 package body System.AST_Handling is
67 package ATID renames Ada.Task_Identification;
69 package ST renames System.Tasking;
70 package STR renames System.Tasking.Rendezvous;
71 package STI renames System.Tasking.Initialization;
72 package STU renames System.Tasking.Utilities;
74 package SSE renames System.Storage_Elements;
75 package STPO renames System.Task_Primitives.Operations;
76 package STPOD renames System.Task_Primitives.Operations.DEC;
78 AST_Lock : aliased System.Task_Primitives.RTS_Lock;
79 -- This is a global lock; it is used to execute in mutual exclusion
80 -- from all other AST tasks. It is only used by Lock_AST and
83 procedure Lock_AST (Self_ID : ST.Task_ID);
84 -- Locks out other AST tasks. Preceding a section of code by Lock_AST and
85 -- following it by Unlock_AST creates a critical region.
87 procedure Unlock_AST (Self_ID : ST.Task_ID);
88 -- Releases lock previously set by call to Lock_AST.
89 -- All nested locks must be released before other tasks competing for the
90 -- tasking lock are released.
96 procedure Lock_AST (Self_ID : ST.Task_ID) is
98 STI.Defer_Abort_Nestable (Self_ID);
99 STPO.Write_Lock (AST_Lock'Access);
106 procedure Unlock_AST (Self_ID : ST.Task_ID) is
108 STPO.Unlock (AST_Lock'Access);
109 STI.Undefer_Abort_Nestable (Self_ID);
112 ---------------------------------
113 -- AST_Handler Data Structures --
114 ---------------------------------
116 -- As noted in the private part of the spec of System.Aux_DEC, the
117 -- AST_Handler type is simply a pointer to a procedure that takes
118 -- a single 64bit parameter. The following is a local copy
119 -- of that definition.
121 -- We need our own copy because we need to get our hands on this
122 -- and we cannot see the private part of System.Aux_DEC. We don't
123 -- want to be a child of Aux_Dec because of complications resulting
124 -- from the use of pragma Extend_System. We will use unchecked
125 -- conversions between the two versions of the declarations.
127 type AST_Handler is access procedure (Param : Long_Integer);
129 -- However, this declaration is somewhat misleading, since the values
130 -- referenced by AST_Handler values (all produced in this package by
131 -- calls to Create_AST_Handler) are highly stylized.
133 -- The first point is that in VMS/Alpha, procedure pointers do not in
134 -- fact point to code, but rather to a 48-byte procedure descriptor.
135 -- So a value of type AST_Handler is in fact a pointer to one of these
136 -- 48-byte descriptors.
138 type Descriptor_Type is new SSE.Storage_Array (1 .. 48);
139 for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
140 type Descriptor_Ref is access all Descriptor_Type;
142 -- Normally, there is only one such descriptor for a given procedure, but
143 -- it works fine to make a copy of the single allocated descriptor, and
144 -- use the copy itself, and we take advantage of this in the design here.
145 -- The idea is that AST_Handler values will all point to a record with the
146 -- following structure:
148 -- Note: When we say it works fine, there is one delicate point, which
149 -- is that the code for the AST procedure itself requires the original
150 -- descriptor address. We handle this by saving the orignal descriptor
151 -- address in this structure and restoring in Process_AST.
153 type AST_Handler_Data is record
154 Descriptor : Descriptor_Type;
155 Original_Descriptor_Ref : Descriptor_Ref;
156 Taskid : ATID.Task_Id;
160 type AST_Handler_Data_Ref is access all AST_Handler_Data;
162 function To_AST_Handler is new Ada.Unchecked_Conversion
163 (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
165 function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
166 (System.Aux_DEC.AST_Handler, AST_Handler_Data_Ref);
168 function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
169 (AST_Handler, AST_Handler_Data_Ref);
171 -- Each time Create_AST_Handler is called, a new value of this record
172 -- type is created, containing a copy of the procedure descriptor for
173 -- the routine used to handle all AST's (Process_AST), and the Task_Id
174 -- and entry number parameters identifying the task entry involved.
176 -- The AST_Handler value returned is a pointer to this record. Since
177 -- the record starts with the procedure descriptor, it can be used
178 -- by the system in the normal way to call the procedure. But now
179 -- when the procedure gets control, it can determine the address of
180 -- the procedure descriptor used to call it (since the ABI specifies
181 -- that this is left sitting in register r27 on entry), and then use
182 -- that address to retrieve the Task_Id and entry number so that it
183 -- knows on which entry to queue the AST request.
185 -- The next issue is where are these records placed. Since we intend
186 -- to pass pointers to these records to asynchronous system service
187 -- routines, they have to be on the heap, which means we have to worry
188 -- about when to allocate them and deallocate them.
190 -- We solve this problem by introducing a task attribute that points to
191 -- a vector, indexed by the entry number, of AST_Handler_Data records
192 -- for a given task. The pointer itself is a controlled object allowing
193 -- us to write a finalization routine that frees the referenced vector.
195 -- An entry in this vector is either initialized (Entryno non-zero) and
196 -- can be used for any subsequent reference to the same entry, or it is
197 -- unused, marked by the Entryno value being zero.
199 type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
200 type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
201 procedure Free is new Ada.Unchecked_Deallocation
202 (Object => AST_Handler_Vector,
203 Name => AST_Handler_Vector_Ref);
205 -- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
206 -- removed due to problem with controlled attribute, consequence is that
207 -- we have a memory leak if a task that has AST attribute entries is
210 type AST_Vector_Ptr is record
211 Vector : AST_Handler_Vector_Ref;
214 procedure Finalize (Object : in out AST_Vector_Ptr);
215 -- Used to get rid of allocated AST_Vector's
217 AST_Vector_Init : AST_Vector_Ptr;
218 -- Initial value, treated as constant, Vector will be null.
220 package AST_Attribute is new Ada.Task_Attributes
221 (Attribute => AST_Vector_Ptr,
222 Initial_Value => AST_Vector_Init);
226 -----------------------
227 -- AST Service Queue --
228 -----------------------
230 -- The following global data structures are used to queue pending
231 -- AST requests. When an AST is signalled, the AST service routine
232 -- Process_AST is called, and it makes an entry in this structure.
234 type AST_Instance is record
235 Taskid : ATID.Task_Id;
237 Param : Long_Integer;
239 -- The Taskid and Entryno indicate the entry on which this AST is to
240 -- be queued, and Param is the parameter provided from the AST itself.
242 AST_Service_Queue_Size : constant := 256;
243 AST_Service_Queue_Limit : constant := 250;
244 type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
245 -- Index used to refer to entries in the circular buffer which holds
246 -- active AST_Instance values. The upper bound reflects the maximum
247 -- number of AST instances that can be stored in the buffer. Since
248 -- these entries are immediately serviced by the high priority server
249 -- task that does the actual entry queuing, it is very unusual to have
250 -- any significant number of entries simulaneously queued.
252 AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
253 pragma Volatile_Components (AST_Service_Queue);
254 -- The circular buffer used to store active AST requests.
256 AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
257 AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
258 pragma Atomic (AST_Service_Queue_Put);
259 pragma Atomic (AST_Service_Queue_Get);
260 -- These two variables point to the next slots in the AST_Service_Queue
261 -- to be used for putting a new entry in and taking an entry out. This
262 -- is a circular buffer, so these pointers wrap around. If the two values
263 -- are equal the buffer is currently empty. The pointers are atomic to
264 -- ensure proper synchronization between the single producer (namely the
265 -- Process_AST procedure), and the single consumer (the AST_Service_Task).
267 --------------------------------
268 -- AST Server Task Structures --
269 --------------------------------
271 -- The basic approach is that when an AST comes in, a call is made to
272 -- the Process_AST procedure. It queues the request in the service queue
273 -- and then wakes up an AST server task to perform the actual call to the
274 -- required entry. We use this intermediate server task, since the AST
275 -- procedure itself cannot wait to return, and we need some caller for
276 -- the rendezvous so that we can use the normal rendezvous mechanism.
278 -- It would work to have only one AST server task, but then we would lose
279 -- all overlap in AST processing, and furthermore, we could get priority
280 -- inversion effects resulting in starvation of AST requests.
282 -- We therefore maintain a small pool of AST server tasks. We adjust
283 -- the size of the pool dynamically to reflect traffic, so that we have
284 -- a sufficient number of server tasks to avoid starvation.
286 Max_AST_Servers : constant Natural := 16;
287 -- Maximum number of AST server tasks that can be allocated
289 Num_AST_Servers : Natural := 0;
290 -- Number of AST server tasks currently active
292 Num_Waiting_AST_Servers : Natural := 0;
293 -- This is the number of AST server tasks that are either waiting for
294 -- work, or just about to go to sleep and wait for work.
296 Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
297 -- An array of flags showing which AST server tasks are currently waiting
299 AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_ID;
300 -- Task Id's of allocated AST server tasks
302 task type AST_Server_Task (Num : Natural) is
303 pragma Priority (Priority'Last);
305 -- Declaration for AST server task. This task has no entries, it is
306 -- controlled by sleep and wakeup calls at the task primitives level.
308 type AST_Server_Task_Ptr is access all AST_Server_Task;
309 -- Type used to allocate server tasks
311 function To_Integer is new Ada.Unchecked_Conversion
312 (ATID.Task_Id, Integer);
314 -----------------------
315 -- Local Subprograms --
316 -----------------------
318 procedure Allocate_New_AST_Server;
319 -- Allocate an additional AST server task
321 procedure Process_AST (Param : Long_Integer);
322 -- This is the central routine for processing all AST's, it is referenced
323 -- as the code address of all created AST_Handler values. See detailed
324 -- description in body to understand how it works to have a single such
325 -- procedure for all AST's even though it does not get any indication of
326 -- the entry involved passed as an explicit parameter. The single explicit
327 -- parameter Param is the parameter passed by the system with the AST.
329 -----------------------------
330 -- Allocate_New_AST_Server --
331 -----------------------------
333 procedure Allocate_New_AST_Server is
334 Dummy : AST_Server_Task_Ptr;
337 if Num_AST_Servers = Max_AST_Servers then
341 -- Note: it is safe to increment Num_AST_Servers immediately, since
342 -- no one will try to activate this task until it indicates that it
343 -- is sleeping by setting its entry in Is_Waiting to True.
345 Num_AST_Servers := Num_AST_Servers + 1;
346 Dummy := new AST_Server_Task (Num_AST_Servers);
348 end Allocate_New_AST_Server;
350 ---------------------
351 -- AST_Server_Task --
352 ---------------------
354 task body AST_Server_Task is
355 Taskid : ATID.Task_Id;
357 Param : aliased Long_Integer;
358 Self_Id : constant ST.Task_ID := ST.Self;
360 pragma Volatile (Param);
363 -- By making this task independent of master, when the environment
364 -- task is finalizing, the AST_Server_Task will be notified that it
367 STU.Make_Independent;
369 -- Record our task Id for access by Process_AST
371 AST_Task_Ids (Num) := Self_Id;
373 -- Note: this entire task operates with the main task lock set, except
374 -- when it is sleeping waiting for work, or busy doing a rendezvous
375 -- with an AST server. This lock protects the data structures that
376 -- are shared by multiple instances of the server task.
380 -- This is the main infinite loop of the task. We go to sleep and
381 -- wait to be woken up by Process_AST when there is some work to do.
384 Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
386 Unlock_AST (Self_Id);
388 STI.Defer_Abort (Self_Id);
389 STPO.Write_Lock (Self_Id);
391 Is_Waiting (Num) := True;
393 Self_Id.Common.State := ST.AST_Server_Sleep;
394 STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
395 Self_Id.Common.State := ST.Runnable;
397 STPO.Unlock (Self_Id);
399 -- If the process is finalizing, Undefer_Abort will simply end
402 STI.Undefer_Abort (Self_Id);
404 -- We are awake, there is something to do!
407 Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
409 -- Loop here to service outstanding requests. We are always
410 -- locked on entry to this loop.
412 while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
413 Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
414 Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
415 Param := AST_Service_Queue (AST_Service_Queue_Get).Param;
417 AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
419 -- This is a manual expansion of the normal call simple code
422 type AA is access all Long_Integer;
423 P : AA := Param'Unrestricted_Access;
425 function To_ST_Task_Id is new Ada.Unchecked_Conversion
426 (ATID.Task_Id, ST.Task_ID);
429 Unlock_AST (Self_Id);
431 (Acceptor => To_ST_Task_Id (Taskid),
432 E => ST.Task_Entry_Index (Entryno),
433 Uninterpreted_Data => P'Address);
436 System.IO.Put_Line ("%Debugging event");
437 System.IO.Put_Line (Exception_Name (E) &
438 " raised when trying to deliver an AST.");
439 if Exception_Message (E)'Length /= 0 then
440 System.IO.Put_Line (Exception_Message (E));
442 System.IO.Put_Line ("Task type is " & "Receiver_Type");
443 System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
451 ------------------------
452 -- Create_AST_Handler --
453 ------------------------
455 function Create_AST_Handler
456 (Taskid : ATID.Task_Id;
458 return System.Aux_DEC.AST_Handler
460 Attr_Ref : Attribute_Handle;
462 Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
463 -- Reference to standard procedure descriptor for Process_AST
465 function To_Descriptor_Ref is new Ada.Unchecked_Conversion
466 (AST_Handler, Descriptor_Ref);
468 Original_Descriptor_Ref : Descriptor_Ref :=
469 To_Descriptor_Ref (Process_AST_Ptr);
472 if ATID.Is_Terminated (Taskid) then
476 Attr_Ref := Reference (Taskid);
478 -- Allocate another server if supply is getting low
480 if Num_Waiting_AST_Servers < 2 then
481 Allocate_New_AST_Server;
484 -- No point in creating more if we have zillions waiting to
487 while AST_Service_Queue_Put - AST_Service_Queue_Get
488 > AST_Service_Queue_Limit
493 -- If no AST vector allocated, or the one we have is too short, then
494 -- allocate one of right size and initialize all entries except the
495 -- one we will use to unused. Note that the assignment automatically
496 -- frees the old allocated table if there is one.
498 if Attr_Ref.Vector = null
499 or else Attr_Ref.Vector'Length < Entryno
501 Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
503 for E in 1 .. Entryno loop
504 Attr_Ref.Vector (E).Descriptor :=
505 Original_Descriptor_Ref.all;
506 Attr_Ref.Vector (E).Original_Descriptor_Ref :=
507 Original_Descriptor_Ref;
508 Attr_Ref.Vector (E).Taskid := Taskid;
509 Attr_Ref.Vector (E).Entryno := E;
513 return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
514 end Create_AST_Handler;
516 ----------------------------
517 -- Expand_AST_Packet_Pool --
518 ----------------------------
520 procedure Expand_AST_Packet_Pool
521 (Requested_Packets : in Natural;
522 Actual_Number : out Natural;
523 Total_Number : out Natural)
526 -- The AST implementation of GNAT does not permit dynamic expansion
527 -- of the pool, so we simply add no entries and return the total. If
528 -- it is necessary to expand the allocation, then this package body
529 -- must be recompiled with a larger value for AST_Service_Queue_Size.
532 Total_Number := AST_Service_Queue_Size;
533 end Expand_AST_Packet_Pool;
539 procedure Finalize (Object : in out AST_Vector_Ptr) is
541 Free (Object.Vector);
548 procedure Process_AST (Param : Long_Integer) is
550 Handler_Data_Ptr : AST_Handler_Data_Ref;
551 -- This variable is set to the address of the descriptor through
552 -- which Process_AST is called. Since the descriptor is part of
553 -- an AST_Handler value, this is also the address of this value,
554 -- from which we can obtain the task and entry number information.
556 function To_Address is new Ada.Unchecked_Conversion
557 (ST.Task_ID, System.Address);
560 System.Machine_Code.Asm
561 (Template => "addl $27,0,%0",
562 Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
565 System.Machine_Code.Asm
566 (Template => "ldl $27,%0",
567 Inputs => Descriptor_Ref'Asm_Input
568 ("m", Handler_Data_Ptr.Original_Descriptor_Ref),
571 AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
572 (Taskid => Handler_Data_Ptr.Taskid,
573 Entryno => Handler_Data_Ptr.Entryno,
576 -- ??? What is the protection of this variable ?
577 -- It seems that trying to use any lock in this procedure will get
580 AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
582 -- Need to wake up processing task. If there is no waiting server
583 -- then we have temporarily run out, but things should still be
584 -- OK, since one of the active ones will eventually pick up the
585 -- service request queued in the AST_Service_Queue.
587 for J in 1 .. Num_AST_Servers loop
588 if Is_Waiting (J) then
589 Is_Waiting (J) := False;
591 -- Sleeps are handled by ASTs on VMS, so don't call Wakeup.
592 -- ??? We should lock AST_Task_Ids (J) here. What's the story ?
594 STPOD.Interrupt_AST_Handler
595 (To_Address (AST_Task_Ids (J)));
602 STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
603 end System.AST_Handling;