1------------------------------------------------------------------------------ 2-- -- 3-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2003 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 2, or (at your option) any later ver- -- 14-- sion. GNARL 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 GNARL; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 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. -- 28-- -- 29-- GNARL was developed by the GNARL team at Florida State University. -- 30-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34-- This package is for OpenVMS/Alpha 35 36with System.OS_Interface; 37with System.Parameters; 38with System.Tasking; 39with Unchecked_Conversion; 40with System.Soft_Links; 41 42package body System.Task_Primitives.Operations.DEC is 43 44 use System.OS_Interface; 45 use System.Parameters; 46 use System.Tasking; 47 use System.Aux_DEC; 48 use type Interfaces.C.int; 49 50 package SSL renames System.Soft_Links; 51 52 -- The FAB_RAB_Type specifies where the context field (the calling 53 -- task) is stored. Other fields defined for FAB_RAB arent' need and 54 -- so are ignored. 55 56 type FAB_RAB_Type is record 57 CTX : Unsigned_Longword; 58 end record; 59 60 for FAB_RAB_Type use record 61 CTX at 24 range 0 .. 31; 62 end record; 63 64 for FAB_RAB_Type'Size use 224; 65 66 type FAB_RAB_Access_Type is access all FAB_RAB_Type; 67 68 ----------------------- 69 -- Local Subprograms -- 70 ----------------------- 71 72 function To_Unsigned_Longword is new 73 Unchecked_Conversion (Task_ID, Unsigned_Longword); 74 75 function To_Task_Id is new 76 Unchecked_Conversion (Unsigned_Longword, Task_ID); 77 78 function To_FAB_RAB is new 79 Unchecked_Conversion (Address, FAB_RAB_Access_Type); 80 81 --------------------------- 82 -- Interrupt_AST_Handler -- 83 --------------------------- 84 85 procedure Interrupt_AST_Handler (ID : Address) is 86 Result : Interfaces.C.int; 87 AST_Self_ID : Task_ID := To_Task_Id (ID); 88 89 begin 90 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 91 pragma Assert (Result = 0); 92 end Interrupt_AST_Handler; 93 94 --------------------- 95 -- RMS_AST_Handler -- 96 --------------------- 97 98 procedure RMS_AST_Handler (ID : Address) is 99 AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX); 100 Result : Interfaces.C.int; 101 102 begin 103 AST_Self_ID.Common.LL.AST_Pending := False; 104 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 105 pragma Assert (Result = 0); 106 end RMS_AST_Handler; 107 108 ---------- 109 -- Self -- 110 ---------- 111 112 function Self return Unsigned_Longword is 113 Self_ID : Task_ID := Self; 114 begin 115 Self_ID.Common.LL.AST_Pending := True; 116 return To_Unsigned_Longword (Self); 117 end Self; 118 119 ------------------------- 120 -- Starlet_AST_Handler -- 121 ------------------------- 122 123 procedure Starlet_AST_Handler (ID : Address) is 124 Result : Interfaces.C.int; 125 AST_Self_ID : Task_ID := To_Task_Id (ID); 126 127 begin 128 AST_Self_ID.Common.LL.AST_Pending := False; 129 Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); 130 pragma Assert (Result = 0); 131 end Starlet_AST_Handler; 132 133 ---------------- 134 -- Task_Synch -- 135 ---------------- 136 137 procedure Task_Synch is 138 Synch_Self_ID : constant Task_ID := Self; 139 begin 140 if Single_Lock then 141 Lock_RTS; 142 else 143 Write_Lock (Synch_Self_ID); 144 end if; 145 146 SSL.Abort_Defer.all; 147 Synch_Self_ID.Common.State := AST_Server_Sleep; 148 149 while Synch_Self_ID.Common.LL.AST_Pending loop 150 Sleep (Synch_Self_ID, AST_Server_Sleep); 151 end loop; 152 153 Synch_Self_ID.Common.State := Runnable; 154 155 if Single_Lock then 156 Unlock_RTS; 157 else 158 Unlock (Synch_Self_ID); 159 end if; 160 161 SSL.Abort_Undefer.all; 162 end Task_Synch; 163 164end System.Task_Primitives.Operations.DEC; 165