summaryrefslogtreecommitdiff
path: root/gcc/ada/s-asthan-vms-alpha.adb
blob: 623538f8613e5256fdf089df18dce5f2874ff0d0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
------------------------------------------------------------------------------
--                                                                          --
--                        GNAT RUN-TIME COMPONENTS                          --
--                                                                          --
--                  S Y S T E M . A S T _ H A N D L I N G                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1996-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the OpenVMS/Alpha version

with System; use System;

with System.IO;

with System.Machine_Code;
with System.Parameters;
with System.Storage_Elements;

with System.Tasking;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Tasking.Utilities;

with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;

with Ada.Finalization;
with Ada.Task_Attributes;

with Ada.Exceptions; use Ada.Exceptions;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;

package body System.AST_Handling is

   package ATID renames Ada.Task_Identification;

   package SP   renames System.Parameters;
   package ST   renames System.Tasking;
   package STR  renames System.Tasking.Rendezvous;
   package STI  renames System.Tasking.Initialization;
   package STU  renames System.Tasking.Utilities;

   package SSE  renames System.Storage_Elements;
   package STPO renames System.Task_Primitives.Operations;
   package STPOD renames System.Task_Primitives.Operations.DEC;

   AST_Lock : aliased System.Task_Primitives.RTS_Lock;
   --  This is a global lock; it is used to execute in mutual exclusion
   --  from all other AST tasks.  It is only used by Lock_AST and
   --  Unlock_AST.

   procedure Lock_AST (Self_ID : ST.Task_Id);
   --  Locks out other AST tasks. Preceding a section of code by Lock_AST and
   --  following it by Unlock_AST creates a critical region.

   procedure Unlock_AST (Self_ID : ST.Task_Id);
   --  Releases lock previously set by call to Lock_AST.
   --  All nested locks must be released before other tasks competing for the
   --  tasking lock are released.

   --------------
   -- Lock_AST --
   --------------

   procedure Lock_AST (Self_ID : ST.Task_Id) is
   begin
      STI.Defer_Abort_Nestable (Self_ID);
      STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
   end Lock_AST;

   ----------------
   -- Unlock_AST --
   ----------------

   procedure Unlock_AST (Self_ID : ST.Task_Id) is
   begin
      STPO.Unlock (AST_Lock'Access, Global_Lock => True);
      STI.Undefer_Abort_Nestable (Self_ID);
   end Unlock_AST;

   ---------------------------------
   -- AST_Handler Data Structures --
   ---------------------------------

   --  As noted in the private part of the spec of System.Aux_DEC, the
   --  AST_Handler type is simply a pointer to a procedure that takes
   --  a single 64bit parameter. The following is a local copy
   --  of that definition.

   --  We need our own copy because we need to get our hands on this
   --  and we cannot see the private part of System.Aux_DEC. We don't
   --  want to be a child of Aux_Dec because of complications resulting
   --  from the use of pragma Extend_System. We will use unchecked
   --  conversions between the two versions of the declarations.

   type AST_Handler is access procedure (Param : Long_Integer);

   --  However, this declaration is somewhat misleading, since the values
   --  referenced by AST_Handler values (all produced in this package by
   --  calls to Create_AST_Handler) are highly stylized.

   --  The first point is that in VMS/Alpha, procedure pointers do not in
   --  fact point to code, but rather to a 48-byte procedure descriptor.
   --  So a value of type AST_Handler is in fact a pointer to one of these
   --  48-byte descriptors.

   type Descriptor_Type is new SSE.Storage_Array (1 .. 48);
   for  Descriptor_Type'Alignment use Standard'Maximum_Alignment;

   type Descriptor_Ref is access all Descriptor_Type;

   --  Normally, there is only one such descriptor for a given procedure, but
   --  it works fine to make a copy of the single allocated descriptor, and
   --  use the copy itself, and we take advantage of this in the design here.
   --  The idea is that AST_Handler values will all point to a record with the
   --  following structure:

   --  Note: When we say it works fine, there is one delicate point, which
   --  is that the code for the AST procedure itself requires the original
   --  descriptor address.  We handle this by saving the original descriptor
   --  address in this structure and restoring in Process_AST.

   type AST_Handler_Data is record
      Descriptor              : Descriptor_Type;
      Original_Descriptor_Ref : Descriptor_Ref;
      Taskid                  : ATID.Task_Id;
      Entryno                 : Natural;
   end record;

   type AST_Handler_Data_Ref is access all AST_Handler_Data;

   function To_AST_Handler is new Ada.Unchecked_Conversion
     (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);

   --  Each time Create_AST_Handler is called, a new value of this record
   --  type is created, containing a copy of the procedure descriptor for
   --  the routine used to handle all AST's (Process_AST), and the Task_Id
   --  and entry number parameters identifying the task entry involved.

   --  The AST_Handler value returned is a pointer to this record. Since
   --  the record starts with the procedure descriptor, it can be used
   --  by the system in the normal way to call the procedure. But now
   --  when the procedure gets control, it can determine the address of
   --  the procedure descriptor used to call it (since the ABI specifies
   --  that this is left sitting in register r27 on entry), and then use
   --  that address to retrieve the Task_Id and entry number so that it
   --  knows on which entry to queue the AST request.

   --  The next issue is where are these records placed. Since we intend
   --  to pass pointers to these records to asynchronous system service
   --  routines, they have to be on the heap, which means we have to worry
   --  about when to allocate them and deallocate them.

   --  We solve this problem by introducing a task attribute that points to
   --  a vector, indexed by the entry number, of AST_Handler_Data records
   --  for a given task. The pointer itself is a controlled object allowing
   --  us to write a finalization routine that frees the referenced vector.

   --  An entry in this vector is either initialized (Entryno non-zero) and
   --  can be used for any subsequent reference to the same entry, or it is
   --  unused, marked by the Entryno value being zero.

   type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
   type AST_Handler_Vector_Ref is access all AST_Handler_Vector;

   type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
      Vector : AST_Handler_Vector_Ref;
   end record;

   procedure Finalize (Obj : in out AST_Vector_Ptr);
   --  Override Finalize so that the AST Vector gets freed.

   procedure Finalize (Obj : in out AST_Vector_Ptr) is
      procedure Free is new
       Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
   begin
      if Obj.Vector /= null then
         Free (Obj.Vector);
      end if;
   end Finalize;

   AST_Vector_Init : AST_Vector_Ptr;
   --  Initial value, treated as constant, Vector will be null

   package AST_Attribute is new Ada.Task_Attributes
     (Attribute     => AST_Vector_Ptr,
      Initial_Value => AST_Vector_Init);

   use AST_Attribute;

   -----------------------
   -- AST Service Queue --
   -----------------------

   --  The following global data structures are used to queue pending
   --  AST requests. When an AST is signalled, the AST service routine
   --  Process_AST is called, and it makes an entry in this structure.

   type AST_Instance is record
      Taskid  : ATID.Task_Id;
      Entryno : Natural;
      Param   : Long_Integer;
   end record;
   --  The Taskid and Entryno indicate the entry on which this AST is to
   --  be queued, and Param is the parameter provided from the AST itself.

   AST_Service_Queue_Size  : constant := 256;
   AST_Service_Queue_Limit : constant := 250;
   type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
   --  Index used to refer to entries in the circular buffer which holds
   --  active AST_Instance values. The upper bound reflects the maximum
   --  number of AST instances that can be stored in the buffer. Since
   --  these entries are immediately serviced by the high priority server
   --  task that does the actual entry queuing, it is very unusual to have
   --  any significant number of entries simultaneously queued.

   AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
   pragma Volatile_Components (AST_Service_Queue);
   --  The circular buffer used to store active AST requests

   AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
   AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
   pragma Atomic (AST_Service_Queue_Put);
   pragma Atomic (AST_Service_Queue_Get);
   --  These two variables point to the next slots in the AST_Service_Queue
   --  to be used for putting a new entry in and taking an entry out. This
   --  is a circular buffer, so these pointers wrap around. If the two values
   --  are equal the buffer is currently empty. The pointers are atomic to
   --  ensure proper synchronization between the single producer (namely the
   --  Process_AST procedure), and the single consumer (the AST_Service_Task).

   --------------------------------
   -- AST Server Task Structures --
   --------------------------------

   --  The basic approach is that when an AST comes in, a call is made to
   --  the Process_AST procedure. It queues the request in the service queue
   --  and then wakes up an AST server task to perform the actual call to the
   --  required entry. We use this intermediate server task, since the AST
   --  procedure itself cannot wait to return, and we need some caller for
   --  the rendezvous so that we can use the normal rendezvous mechanism.

   --  It would work to have only one AST server task, but then we would lose
   --  all overlap in AST processing, and furthermore, we could get priority
   --  inversion effects resulting in starvation of AST requests.

   --  We therefore maintain a small pool of AST server tasks. We adjust
   --  the size of the pool dynamically to reflect traffic, so that we have
   --  a sufficient number of server tasks to avoid starvation.

   Max_AST_Servers : constant Natural := 16;
   --  Maximum number of AST server tasks that can be allocated

   Num_AST_Servers : Natural := 0;
   --  Number of AST server tasks currently active

   Num_Waiting_AST_Servers : Natural := 0;
   --  This is the number of AST server tasks that are either waiting for
   --  work, or just about to go to sleep and wait for work.

   Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
   --  An array of flags showing which AST server tasks are currently waiting

   AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
   --  Task Id's of allocated AST server tasks

   task type AST_Server_Task (Num : Natural) is
      pragma Priority (Priority'Last);
   end AST_Server_Task;
   --  Declaration for AST server task. This task has no entries, it is
   --  controlled by sleep and wakeup calls at the task primitives level.

   type AST_Server_Task_Ptr is access all AST_Server_Task;
   --  Type used to allocate server tasks

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Allocate_New_AST_Server;
   --  Allocate an additional AST server task

   procedure Process_AST (Param : Long_Integer);
   --  This is the central routine for processing all AST's, it is referenced
   --  as the code address of all created AST_Handler values. See detailed
   --  description in body to understand how it works to have a single such
   --  procedure for all AST's even though it does not get any indication of
   --  the entry involved passed as an explicit parameter. The single explicit
   --  parameter Param is the parameter passed by the system with the AST.

   -----------------------------
   -- Allocate_New_AST_Server --
   -----------------------------

   procedure Allocate_New_AST_Server is
      Dummy : AST_Server_Task_Ptr;
      pragma Unreferenced (Dummy);

   begin
      if Num_AST_Servers = Max_AST_Servers then
         return;

      else
         --  Note: it is safe to increment Num_AST_Servers immediately, since
         --  no one will try to activate this task until it indicates that it
         --  is sleeping by setting its entry in Is_Waiting to True.

         Num_AST_Servers := Num_AST_Servers + 1;
         Dummy := new AST_Server_Task (Num_AST_Servers);
      end if;
   end Allocate_New_AST_Server;

   ---------------------
   -- AST_Server_Task --
   ---------------------

   task body AST_Server_Task is
      Taskid  : ATID.Task_Id;
      Entryno : Natural;
      Param   : aliased Long_Integer;
      Self_Id : constant ST.Task_Id := ST.Self;

      pragma Volatile (Param);

   begin
      --  By making this task independent of master, when the environment
      --  task is finalizing, the AST_Server_Task will be notified that it
      --  should terminate.

      STU.Make_Independent;

      --  Record our task Id for access by Process_AST

      AST_Task_Ids (Num) := Self_Id;

      --  Note: this entire task operates with the main task lock set, except
      --  when it is sleeping waiting for work, or busy doing a rendezvous
      --  with an AST server. This lock protects the data structures that
      --  are shared by multiple instances of the server task.

      Lock_AST (Self_Id);

      --  This is the main infinite loop of the task. We go to sleep and
      --  wait to be woken up by Process_AST when there is some work to do.

      loop
         Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;

         Unlock_AST (Self_Id);

         STI.Defer_Abort (Self_Id);

         if SP.Single_Lock then
            STPO.Lock_RTS;
         end if;

         STPO.Write_Lock (Self_Id);

         Is_Waiting (Num) := True;

         Self_Id.Common.State := ST.AST_Server_Sleep;
         STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
         Self_Id.Common.State := ST.Runnable;

         STPO.Unlock (Self_Id);

         if SP.Single_Lock then
            STPO.Unlock_RTS;
         end if;

         --  If the process is finalizing, Undefer_Abort will simply end
         --  this task.

         STI.Undefer_Abort (Self_Id);

         --  We are awake, there is something to do!

         Lock_AST (Self_Id);
         Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;

         --  Loop here to service outstanding requests. We are always
         --  locked on entry to this loop.

         while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
            Taskid  := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
            Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
            Param   := AST_Service_Queue (AST_Service_Queue_Get).Param;

            AST_Service_Queue_Get := AST_Service_Queue_Get + 1;

            --  This is a manual expansion of the normal call simple code

            declare
               type AA is access all Long_Integer;
               P : AA := Param'Unrestricted_Access;

               function To_ST_Task_Id is new Ada.Unchecked_Conversion
                 (ATID.Task_Id, ST.Task_Id);

            begin
               Unlock_AST (Self_Id);
               STR.Call_Simple
                 (Acceptor           => To_ST_Task_Id (Taskid),
                  E                  => ST.Task_Entry_Index (Entryno),
                  Uninterpreted_Data => P'Address);

            exception
               when E : others =>
                  System.IO.Put_Line ("%Debugging event");
                  System.IO.Put_Line (Exception_Name (E) &
                    " raised when trying to deliver an AST.");

                  if Exception_Message (E)'Length /= 0 then
                     System.IO.Put_Line (Exception_Message (E));
                  end if;

                  System.IO.Put_Line ("Task type is " & "Receiver_Type");
                  System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
            end;

            Lock_AST (Self_Id);
         end loop;
      end loop;
   end AST_Server_Task;

   ------------------------
   -- Create_AST_Handler --
   ------------------------

   function Create_AST_Handler
     (Taskid  : ATID.Task_Id;
      Entryno : Natural) return System.Aux_DEC.AST_Handler
   is
      Attr_Ref : Attribute_Handle;

      Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
      --  Reference to standard procedure descriptor for Process_AST

      pragma Warnings (Off, "*alignment*");
      --  Suppress harmless warnings about alignment.
      --  Should explain why this warning is harmless ???

      function To_Descriptor_Ref is new Ada.Unchecked_Conversion
        (AST_Handler, Descriptor_Ref);

      Original_Descriptor_Ref : constant Descriptor_Ref :=
                                  To_Descriptor_Ref (Process_AST_Ptr);

      pragma Warnings (On, "*alignment*");

   begin
      if ATID.Is_Terminated (Taskid) then
         raise Program_Error;
      end if;

      Attr_Ref := Reference (Taskid);

      --  Allocate another server if supply is getting low

      if Num_Waiting_AST_Servers < 2 then
         Allocate_New_AST_Server;
      end if;

      --  No point in creating more if we have zillions waiting to
      --  be serviced.

      while AST_Service_Queue_Put - AST_Service_Queue_Get
         > AST_Service_Queue_Limit
      loop
         delay 0.01;
      end loop;

      --  If no AST vector allocated, or the one we have is too short, then
      --  allocate one of right size and initialize all entries except the
      --  one we will use to unused. Note that the assignment automatically
      --  frees the old allocated table if there is one.

      if Attr_Ref.Vector = null
        or else Attr_Ref.Vector'Length < Entryno
      then
         Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);

         for E in 1 .. Entryno loop
            Attr_Ref.Vector (E).Descriptor :=
              Original_Descriptor_Ref.all;
            Attr_Ref.Vector (E).Original_Descriptor_Ref :=
              Original_Descriptor_Ref;
            Attr_Ref.Vector (E).Taskid  := Taskid;
            Attr_Ref.Vector (E).Entryno := E;
         end loop;
      end if;

      return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
   end Create_AST_Handler;

   ----------------------------
   -- Expand_AST_Packet_Pool --
   ----------------------------

   procedure Expand_AST_Packet_Pool
     (Requested_Packets : Natural;
      Actual_Number     : out Natural;
      Total_Number      : out Natural)
   is
      pragma Unreferenced (Requested_Packets);
   begin
      --  The AST implementation of GNAT does not permit dynamic expansion
      --  of the pool, so we simply add no entries and return the total. If
      --  it is necessary to expand the allocation, then this package body
      --  must be recompiled with a larger value for AST_Service_Queue_Size.

      Actual_Number := 0;
      Total_Number := AST_Service_Queue_Size;
   end Expand_AST_Packet_Pool;

   -----------------
   -- Process_AST --
   -----------------

   procedure Process_AST (Param : Long_Integer) is

      Handler_Data_Ptr : AST_Handler_Data_Ref;
      --  This variable is set to the address of the descriptor through
      --  which Process_AST is called. Since the descriptor is part of
      --  an AST_Handler value, this is also the address of this value,
      --  from which we can obtain the task and entry number information.

      function To_Address is new Ada.Unchecked_Conversion
        (ST.Task_Id, System.Task_Primitives.Task_Address);

   begin
      System.Machine_Code.Asm
        (Template => "addq $27,0,%0",
         Outputs  => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
         Volatile => True);

      System.Machine_Code.Asm
        (Template => "ldq $27,%0",
         Inputs  => Descriptor_Ref'Asm_Input
           ("m", Handler_Data_Ptr.Original_Descriptor_Ref),
         Volatile => True);

      AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
        (Taskid  => Handler_Data_Ptr.Taskid,
         Entryno => Handler_Data_Ptr.Entryno,
         Param   => Param);

      --  OpenVMS Programming Concepts manual, chapter 8.2.3:
      --  "Implicit synchronization can be achieved for data that is shared
      --   for write by using only AST routines to write the data, since only
      --   one AST can be running at any one time."

      --  This subprogram runs at AST level so is guaranteed to be
      --  called sequentially at a given access level.

      AST_Service_Queue_Put := AST_Service_Queue_Put + 1;

      --  Need to wake up processing task. If there is no waiting server
      --  then we have temporarily run out, but things should still be
      --  OK, since one of the active ones will eventually pick up the
      --  service request queued in the AST_Service_Queue.

      for J in 1 .. Num_AST_Servers loop
         if Is_Waiting (J) then
            Is_Waiting (J) := False;

            --  Sleeps are handled by ASTs on VMS, so don't call Wakeup

            STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
            exit;
         end if;
      end loop;
   end Process_AST;

begin
   STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
end System.AST_Handling;