1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This package is for OpenVMS/Alpha 33 34with System.OS_Interface; 35with System.Parameters; 36with System.Tasking; 37with Ada.Unchecked_Conversion; 38with System.Soft_Links; 39 40package body System.Task_Primitives.Operations.DEC is 41 42 use System.OS_Interface; 43 use System.Parameters; 44 use System.Tasking; 45 use System.Aux_DEC; 46 use type Interfaces.C.int; 47 48 package SSL renames System.Soft_Links; 49 50 -- The FAB_RAB_Type specifies where the context field (the calling 51 -- task) is stored. Other fields defined for FAB_RAB arent' need and 52 -- so are ignored. 53 54 type FAB_RAB_Type is record 55 CTX : Unsigned_Longword; 56 end record; 57 58 for FAB_RAB_Type use record 59 CTX at 24 range 0 .. 31; 60 end record; 61 62 for FAB_RAB_Type'Size use 224; 63 64 type FAB_RAB_Access_Type is access all FAB_RAB_Type; 65 66 ----------------------- 67 -- Local Subprograms -- 68 ----------------------- 69 70 function To_Unsigned_Longword is new 71 Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); 72 73 function To_Task_Id is new 74 Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id); 75 76 function To_FAB_RAB is new 77 Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type); 78 79 --------------------------- 80 -- Interrupt_AST_Handler -- 81 --------------------------- 82 83 procedure Interrupt_AST_Handler (ID : Address) is 84 Result : Interfaces.C.int; 85 AST_Self_ID : constant Task_Id := To_Task_Id (ID); 86 begin 87 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 88 pragma Assert (Result = 0); 89 end Interrupt_AST_Handler; 90 91 --------------------- 92 -- RMS_AST_Handler -- 93 --------------------- 94 95 procedure RMS_AST_Handler (ID : Address) is 96 AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX); 97 Result : Interfaces.C.int; 98 99 begin 100 AST_Self_ID.Common.LL.AST_Pending := False; 101 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 102 pragma Assert (Result = 0); 103 end RMS_AST_Handler; 104 105 ---------- 106 -- Self -- 107 ---------- 108 109 function Self return Unsigned_Longword is 110 Self_ID : constant Task_Id := Self; 111 begin 112 Self_ID.Common.LL.AST_Pending := True; 113 return To_Unsigned_Longword (Self); 114 end Self; 115 116 ------------------------- 117 -- Starlet_AST_Handler -- 118 ------------------------- 119 120 procedure Starlet_AST_Handler (ID : Address) is 121 Result : Interfaces.C.int; 122 AST_Self_ID : constant Task_Id := To_Task_Id (ID); 123 begin 124 AST_Self_ID.Common.LL.AST_Pending := False; 125 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 126 pragma Assert (Result = 0); 127 end Starlet_AST_Handler; 128 129 ---------------- 130 -- Task_Synch -- 131 ---------------- 132 133 procedure Task_Synch is 134 Synch_Self_ID : constant Task_Id := Self; 135 136 begin 137 if Single_Lock then 138 Lock_RTS; 139 else 140 Write_Lock (Synch_Self_ID); 141 end if; 142 143 SSL.Abort_Defer.all; 144 Synch_Self_ID.Common.State := AST_Server_Sleep; 145 146 while Synch_Self_ID.Common.LL.AST_Pending loop 147 Sleep (Synch_Self_ID, AST_Server_Sleep); 148 end loop; 149 150 Synch_Self_ID.Common.State := Runnable; 151 152 if Single_Lock then 153 Unlock_RTS; 154 else 155 Unlock (Synch_Self_ID); 156 end if; 157 158 SSL.Abort_Undefer.all; 159 end Task_Synch; 160 161end System.Task_Primitives.Operations.DEC; 162